st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 06:48:48 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions
lama_byterun/runtime/runtime.c

1307 lines
29 KiB
C
Raw Blame History

/* Runtime library */
#define _GNU_SOURCE 1
#include "runtime.h"
#include "gc.h"
#include "runtime_common.h"
#define __ENABLE_GC__
#ifndef __ENABLE_GC__
# define alloc malloc
#endif
#ifdef __ENABLE_GC__
/* GC extern invariant for built-in functions */
extern void __pre_gc ();
extern void __post_gc ();
#else
# define __pre_gc __pre_gc_subst
# define __post_gc __post_gc_subst
void __pre_gc_subst () { }
void __post_gc_subst () { }
#endif
/* end */
#define PRE_GC() \
bool flag = true; \
if (__gc_stack_top == 0) { flag = false; } \
__pre_gc(); \
assert(__gc_stack_top != 0); \
assert(__builtin_frame_address(0) <= (void *)__gc_stack_top);
//#define PRE_GC() \
// bool flag = true; \
// if (__gc_stack_top == 0) { flag = false; } \
// if (!flag) __gc_stack_top = (size_t)__builtin_frame_address(0); \
// assert(__builtin_frame_address(0) <= (void *)__gc_stack_top);
#define POST_GC() \
assert(__builtin_frame_address(0) <= (void *)__gc_stack_top); \
__post_gc(); \
\
if (!flag && __gc_stack_top != 0) { \
fprintf(stderr, "Moving stack???\n"); \
assert(false); \
}
//#define POST_GC() \
// if (!flag) { __gc_stack_top = 0; }
extern size_t __gc_stack_top, __gc_stack_bottom;
static void vfailure (char *s, va_list args) {
fprintf(stderr, "*** FAILURE: ");
vfprintf(stderr, s, args); // vprintf (char *, va_list) <-> printf (char *, ...)
exit(255);
}
void failure (char *s, ...) {
va_list args;
va_start(args, s);
vfailure(s, args);
}
void Lassert (void *f, char *s, ...) {
if (!UNBOX(f)) {
va_list args;
va_start(args, s);
vfailure(s, args);
}
}
#define ASSERT_BOXED(memo, x) \
do \
if (UNBOXED(x)) failure("boxed value expected in %s\n", memo); \
while (0)
#define ASSERT_UNBOXED(memo, x) \
do \
if (!UNBOXED(x)) failure("unboxed value expected in %s\n", memo); \
while (0)
#define ASSERT_STRING(memo, x) \
do \
if (!UNBOXED(x) && TAG(TO_DATA(x)->data_header) != STRING_TAG) \
failure("string value expected in %s\n", memo); \
while (0)
extern void *Bsexp (int n, ...);
extern int LtagHash (char *);
void *global_sysargs;
// Gets a raw data_header
extern int LkindOf (void *p) {
if (UNBOXED(p)) return UNBOXED_TAG;
return TAG(TO_DATA(p)->data_header);
}
// Compare sexprs tags
extern int LcompareTags (void *p, void *q) {
data *pd, *qd;
ASSERT_BOXED("compareTags, 0", p);
ASSERT_BOXED("compareTags, 1", q);
pd = TO_DATA(p);
qd = TO_DATA(q);
if (TAG(pd->data_header) == SEXP_TAG && TAG(qd->data_header) == SEXP_TAG) {
return BOX((TO_SEXP(p)->tag) - (TO_SEXP(q)->tag));
} else {
failure("not a sexpr in compareTags: %d, %d\n", TAG(pd->data_header), TAG(qd->data_header));
}
return 0; // never happens
}
// Functional synonym for built-in operator ":";
void *Ls__Infix_58 (void *p, void *q) {
void *res;
PRE_GC();
push_extra_root(&p);
push_extra_root(&q);
res = Bsexp(BOX(3), p, q, LtagHash("cons")); //BOX(848787));
pop_extra_root(&q);
pop_extra_root(&p);
POST_GC();
return res;
}
// Functional synonym for built-in operator "!!";
int Ls__Infix_3333 (void *p, void *q) {
ASSERT_UNBOXED("captured !!:1", p);
ASSERT_UNBOXED("captured !!:2", q);
return BOX(UNBOX(p) || UNBOX(q));
}
// Functional synonym for built-in operator "&&";
int Ls__Infix_3838 (void *p, void *q) {
ASSERT_UNBOXED("captured &&:1", p);
ASSERT_UNBOXED("captured &&:2", q);
return BOX(UNBOX(p) && UNBOX(q));
}
// Functional synonym for built-in operator "==";
int Ls__Infix_6161 (void *p, void *q) { return BOX(p == q); }
// Functional synonym for built-in operator "!=";
int Ls__Infix_3361 (void *p, void *q) {
ASSERT_UNBOXED("captured !=:1", p);
ASSERT_UNBOXED("captured !=:2", q);
return BOX(UNBOX(p) != UNBOX(q));
}
// Functional synonym for built-in operator "<=";
int Ls__Infix_6061 (void *p, void *q) {
ASSERT_UNBOXED("captured <=:1", p);
ASSERT_UNBOXED("captured <=:2", q);
return BOX(UNBOX(p) <= UNBOX(q));
}
// Functional synonym for built-in operator "<";
int Ls__Infix_60 (void *p, void *q) {
ASSERT_UNBOXED("captured <:1", p);
ASSERT_UNBOXED("captured <:2", q);
return BOX(UNBOX(p) < UNBOX(q));
}
// Functional synonym for built-in operator ">=";
int Ls__Infix_6261 (void *p, void *q) {
ASSERT_UNBOXED("captured >=:1", p);
ASSERT_UNBOXED("captured >=:2", q);
return BOX(UNBOX(p) >= UNBOX(q));
}
// Functional synonym for built-in operator ">";
int Ls__Infix_62 (void *p, void *q) {
ASSERT_UNBOXED("captured >:1", p);
ASSERT_UNBOXED("captured >:2", q);
return BOX(UNBOX(p) > UNBOX(q));
}
// Functional synonym for built-in operator "+";
int Ls__Infix_43 (void *p, void *q) {
ASSERT_UNBOXED("captured +:1", p);
ASSERT_UNBOXED("captured +:2", q);
return BOX(UNBOX(p) + UNBOX(q));
}
// Functional synonym for built-in operator "-";
int Ls__Infix_45 (void *p, void *q) {
if (UNBOXED(p)) {
ASSERT_UNBOXED("captured -:2", q);
return BOX(UNBOX(p) - UNBOX(q));
}
ASSERT_BOXED("captured -:1", q);
return BOX(p - q);
}
// Functional synonym for built-in operator "*";
int Ls__Infix_42 (void *p, void *q) {
ASSERT_UNBOXED("captured *:1", p);
ASSERT_UNBOXED("captured *:2", q);
return BOX(UNBOX(p) * UNBOX(q));
}
// Functional synonym for built-in operator "/";
int Ls__Infix_47 (void *p, void *q) {
ASSERT_UNBOXED("captured /:1", p);
ASSERT_UNBOXED("captured /:2", q);
return BOX(UNBOX(p) / UNBOX(q));
}
// Functional synonym for built-in operator "%";
int Ls__Infix_37 (void *p, void *q) {
ASSERT_UNBOXED("captured %:1", p);
ASSERT_UNBOXED("captured %:2", q);
return BOX(UNBOX(p) % UNBOX(q));
}
extern int Llength (void *p) {
ASSERT_BOXED(".length", p);
return BOX(LEN(TO_DATA(p)->data_header));
}
static char *chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'";
extern char *de_hash (int);
extern int LtagHash (char *s) {
char *p;
int h = 0, limit = 0;
p = s;
while (*p && limit++ <= 4) {
char *q = chars;
int pos = 0;
for (; *q && *q != *p; q++, pos++)
;
if (*q) h = (h << 6) | pos;
else failure("tagHash: character not found: %c\n", *p);
p++;
}
if (strcmp(s, de_hash(h)) != 0) { failure("%s <-> %s\n", s, de_hash(h)); }
return BOX(h);
}
char *de_hash (int n) {
static char buf[6] = {0, 0, 0, 0, 0, 0};
char *p = (char *)BOX(NULL);
p = &buf[5];
*p-- = 0;
while (n != 0) {
*p-- = chars[n & 0x003F];
n = n >> 6;
}
return ++p;
}
typedef struct {
char *contents;
int ptr;
int len;
} StringBuf;
static StringBuf stringBuf;
#define STRINGBUF_INIT 128
static void createStringBuf () {
stringBuf.contents = (char *)malloc(STRINGBUF_INIT);
memset(stringBuf.contents, 0, STRINGBUF_INIT);
stringBuf.ptr = 0;
stringBuf.len = STRINGBUF_INIT;
}
static void deleteStringBuf () { free(stringBuf.contents); }
static void extendStringBuf () {
int len = stringBuf.len << 1;
stringBuf.contents = (char *)realloc(stringBuf.contents, len);
stringBuf.len = len;
}
static void vprintStringBuf (char *fmt, va_list args) {
int written = 0, rest = 0;
char *buf = (char *)BOX(NULL);
va_list vsnargs;
again:
va_copy(vsnargs, args);
buf = &stringBuf.contents[stringBuf.ptr];
rest = stringBuf.len - stringBuf.ptr;
written = vsnprintf(buf, rest, fmt, vsnargs);
va_end(vsnargs);
if (written >= rest) {
extendStringBuf();
goto again;
}
stringBuf.ptr += written;
}
static void printStringBuf (char *fmt, ...) {
va_list args;
va_start(args, fmt);
vprintStringBuf(fmt, args);
}
static void printValue (void *p) {
data *a = (data *)BOX(NULL);
int i = BOX(0);
if (UNBOXED(p)) {
printStringBuf("%d", UNBOX(p));
} else {
if (!is_valid_heap_pointer(p)) {
printStringBuf("0x%x", p);
return;
}
a = TO_DATA(p);
switch (TAG(a->data_header)) {
case STRING_TAG: printStringBuf("\"%s\"", a->contents); break;
case CLOSURE_TAG: {
printStringBuf("<closure ");
for (i = 0; i < LEN(a->data_header); i++) {
if (i) printValue((void *)((int *)a->contents)[i]);
else printStringBuf("0x%x", (void *)((int *)a->contents)[i]);
if (i != LEN(a->data_header) - 1) printStringBuf(", ");
}
printStringBuf(">");
break;
}
case ARRAY_TAG: {
printStringBuf("[");
for (i = 0; i < LEN(a->data_header); i++) {
printValue((void *)((int *)a->contents)[i]);
if (i != LEN(a->data_header) - 1) printStringBuf(", ");
}
printStringBuf("]");
break;
}
case SEXP_TAG: {
sexp *sa = (sexp *)a;
char *tag = de_hash(sa->tag);
if (strcmp(tag, "cons") == 0) {
sexp *sb = sa;
printStringBuf("{");
while (LEN(sb->data_header)) {
printValue((void *)((int *)sb->contents)[0]);
int list_next = ((int *)sb->contents)[1];
if (!UNBOXED(list_next)) {
printStringBuf(", ");
sb = TO_SEXP(list_next);
} else break;
}
printStringBuf("}");
} else {
printStringBuf("%s", tag);
sexp *sexp_a = (sexp *)a;
if (LEN(a->data_header)) {
printStringBuf(" (");
for (i = 0; i < LEN(sexp_a->data_header); i++) {
printValue((void *)((int *)sexp_a->contents)[i]);
if (i != LEN(sexp_a->data_header) - 1) printStringBuf(", ");
}
printStringBuf(")");
}
}
} break;
default: printStringBuf("*** invalid data_header: 0x%x ***", TAG(a->data_header));
}
}
}
static void stringcat (void *p) {
data *a;
int i;
if (UNBOXED(p))
;
else {
a = TO_DATA(p);
switch (TAG(a->data_header)) {
case STRING_TAG: printStringBuf("%s", a->contents); break;
case SEXP_TAG: {
char *tag = de_hash(TO_SEXP(p)->tag);
if (strcmp(tag, "cons") == 0) {
data *b = a;
while (LEN(b->data_header)) {
stringcat((void *)((int *)b->contents)[0]);
b = (data *)((int *)b->contents)[1];
if (!UNBOXED(b)) {
b = TO_DATA(b);
} else break;
}
} else printStringBuf("*** non-list data_header: %s ***", tag);
} break;
default: printStringBuf("*** invalid data_header: 0x%x ***", TAG(a->data_header));
}
}
}
extern int Luppercase (void *v) {
ASSERT_UNBOXED("Luppercase:1", v);
return BOX(toupper((int)UNBOX(v)));
}
extern int Llowercase (void *v) {
ASSERT_UNBOXED("Llowercase:1", v);
return BOX(tolower((int)UNBOX(v)));
}
extern int LmatchSubString (char *subj, char *patt, int pos) {
data *p = TO_DATA(patt), *s = TO_DATA(subj);
int n;
ASSERT_STRING("matchSubString:1", subj);
ASSERT_STRING("matchSubString:2", patt);
ASSERT_UNBOXED("matchSubString:3", pos);
n = LEN(p->data_header);
if (n + UNBOX(pos) > LEN(s->data_header)) return BOX(0);
return BOX(strncmp(subj + UNBOX(pos), patt, n) == 0);
}
extern void *Lsubstring (void *subj, int p, int l) {
data *d = TO_DATA(subj);
int pp = UNBOX(p), ll = UNBOX(l);
ASSERT_STRING("substring:1", subj);
ASSERT_UNBOXED("substring:2", p);
ASSERT_UNBOXED("substring:3", l);
if (pp + ll <= LEN(d->data_header)) {
data *r;
PRE_GC();
push_extra_root(&subj);
r = (data *)alloc_string(ll);
pop_extra_root(&subj);
strncpy(r->contents, (char *)subj + pp, ll);
POST_GC();
return r->contents;
}
failure("substring: index out of bounds (position=%d, length=%d, \
subject length=%d)",
pp,
ll,
LEN(d->data_header));
}
extern struct re_pattern_buffer *Lregexp (char *regexp) {
regex_t *b = (regex_t *)malloc(sizeof(regex_t));
/* printf ("regexp: %s,\t%x\n", regexp, b); */
memset(b, 0, sizeof(regex_t));
int n = (int)re_compile_pattern(regexp, strlen(regexp), b);
if (n != 0) { failure("%", strerror(n)); };
return b;
}
extern int LregexpMatch (struct re_pattern_buffer *b, char *s, int pos) {
int res;
ASSERT_BOXED("regexpMatch:1", b);
ASSERT_STRING("regexpMatch:2", s);
ASSERT_UNBOXED("regexpMatch:3", pos);
res = re_match(b, s, LEN(TO_DATA(s)->data_header), UNBOX(pos), 0);
/* printf ("regexpMatch %x: %s, res=%d\n", b, s+UNBOX(pos), res); */
if (res) { return BOX(res); }
return BOX(res);
}
extern void *Bstring (void *);
void *Lclone (void *p) {
data *obj;
sexp *sobj;
void *res;
int n;
if (UNBOXED(p)) return p;
PRE_GC();
data *a = TO_DATA(p);
int t = TAG(a->data_header), l = LEN(a->data_header);
push_extra_root(&p);
switch (t) {
case STRING_TAG: res = Bstring(TO_DATA(p)->contents); break;
case ARRAY_TAG:
obj = (data *)alloc_array(l);
memcpy(obj, TO_DATA(p), array_size(l));
res = (void *)obj->contents;
break;
case CLOSURE_TAG:
obj = (data *)alloc_closure(l);
memcpy(obj, TO_DATA(p), closure_size(l));
res = (void *)(obj->contents);
break;
case SEXP_TAG:
obj = (data *)alloc_sexp(l);
memcpy(obj, TO_DATA(p), sexp_size(l));
res = (void *)obj->contents;
break;
default: failure("invalid data_header %d in clone *****\n", t);
}
pop_extra_root(&p);
POST_GC();
return res;
}
#define HASH_DEPTH 3
#define HASH_APPEND(acc, x) \
(((acc + (unsigned)x) << (WORD_SIZE / 2)) | ((acc + (unsigned)x) >> (WORD_SIZE / 2)))
int inner_hash (int depth, unsigned acc, void *p) {
if (depth > HASH_DEPTH) return acc;
if (UNBOXED(p)) return HASH_APPEND(acc, UNBOX(p));
else if (is_valid_heap_pointer(p)) {
data *a = TO_DATA(p);
int t = TAG(a->data_header), l = LEN(a->data_header), i;
acc = HASH_APPEND(acc, t);
acc = HASH_APPEND(acc, l);
switch (t) {
case STRING_TAG: {
char *p = a->contents;
while (*p) {
int n = (int)*p++;
acc = HASH_APPEND(acc, n);
}
return acc;
}
case CLOSURE_TAG:
acc = HASH_APPEND(acc, ((void **)a->contents)[0]);
i = 1;
break;
case ARRAY_TAG: i = 0; break;
case SEXP_TAG: {
int ta = TO_SEXP(p)->tag;
acc = HASH_APPEND(acc, ta);
i = 1;
++l;
break;
}
default: failure("invalid data_header %d in hash *****\n", t);
}
for (; i < l; i++) acc = inner_hash(depth + 1, acc, ((void **)a->contents)[i]);
return acc;
} else return HASH_APPEND(acc, p);
}
extern void *LstringInt (char *b) {
int n;
sscanf(b, "%d", &n);
return (void *)BOX(n);
}
extern int Lhash (void *p) { return BOX(0x3fffff & inner_hash(0, 0, p)); }
extern int LflatCompare (void *p, void *q) {
if (UNBOXED(p)) {
if (UNBOXED(q)) { return BOX(UNBOX(p) - UNBOX(q)); }
return -1;
} else if (~UNBOXED(q)) {
return BOX(p - q);
} else BOX(1);
}
extern int Lcompare (void *p, void *q) {
#define COMPARE_AND_RETURN(x, y) \
do \
if (x != y) return BOX(x - y); \
while (0)
if (p == q) return BOX(0);
if (UNBOXED(p)) {
if (UNBOXED(q)) return BOX(UNBOX(p) - UNBOX(q));
else return BOX(-1);
} else if (UNBOXED(q)) return BOX(1);
else {
if (is_valid_heap_pointer(p)) {
if (is_valid_heap_pointer(q)) {
data *a = TO_DATA(p), *b = TO_DATA(q);
int ta = TAG(a->data_header), tb = TAG(b->data_header);
int la = LEN(a->data_header), lb = LEN(b->data_header);
int i;
int shift = 0;
COMPARE_AND_RETURN(ta, tb);
switch (ta) {
case STRING_TAG: return BOX(strcmp(a->contents, b->contents));
case CLOSURE_TAG:
COMPARE_AND_RETURN(((void **)a->contents)[0], ((void **)b->contents)[0]);
COMPARE_AND_RETURN(la, lb);
i = 1;
break;
case ARRAY_TAG:
COMPARE_AND_RETURN(la, lb);
i = 0;
break;
case SEXP_TAG: {
int tag_a = TO_SEXP(p)->tag, tag_b = TO_SEXP(q)->tag;
COMPARE_AND_RETURN(tag_a, tag_b);
COMPARE_AND_RETURN(la, lb);
i = 0;
shift = 1;
break;
}
default: failure("invalid data_header %d in compare *****\n", ta);
}
for (; i < la; i++) {
int c = Lcompare(((void **)a->contents)[i + shift], ((void **)b->contents)[i + shift]);
if (c != BOX(0)) return BOX(c);
}
return BOX(0);
} else return BOX(-1);
} else if (is_valid_heap_pointer(q)) return BOX(1);
else return BOX(p - q);
}
}
extern void *Belem (void *p, int i) {
data *a = (data *)BOX(NULL);
if (UNBOXED(p)) { ASSERT_BOXED(".elem:1", p); }
ASSERT_UNBOXED(".elem:2", i);
a = TO_DATA(p);
i = UNBOX(i);
switch (TAG(a->data_header)) {
case STRING_TAG: return (void *)BOX(a->contents[i]);
case SEXP_TAG: return (void *)((int *)a->contents)[i + 1];
default: return (void *)((int *)a->contents)[i];
}
}
extern void *LmakeArray (int length) {
data *r;
int n, *p;
ASSERT_UNBOXED("makeArray:1", length);
PRE_GC();
n = UNBOX(length);
r = (data *)alloc_array(n);
p = (int *)r->contents;
while (n--) *p++ = BOX(0);
POST_GC();
return r->contents;
}
extern void *LmakeString (int length) {
int n = UNBOX(length);
data *r;
ASSERT_UNBOXED("makeString", length);
PRE_GC();
r = (data *)alloc_string(n); // '\0' in the end of the string is taken into account
POST_GC();
return r->contents;
}
extern void *Bstring (void *p) {
int n = strlen(p);
void *s = NULL;
PRE_GC();
push_extra_root(&p);
s = LmakeString(BOX(n));
pop_extra_root(&p);
strncpy((char *)&TO_DATA(s)->contents, p, n + 1); // +1 because of '\0' in the end of C-strings
POST_GC();
return s;
}
extern void *Lstringcat (void *p) {
void *s;
/* ASSERT_BOXED("stringcat", p); */
PRE_GC();
createStringBuf();
stringcat(p);
push_extra_root(&p);
s = Bstring(stringBuf.contents);
pop_extra_root(&p);
deleteStringBuf();
POST_GC();
return s;
}
extern void *Lstring (void *p) {
void *s = (void *)BOX(NULL);
PRE_GC();
createStringBuf();
printValue(p);
push_extra_root(&p);
s = Bstring(stringBuf.contents);
pop_extra_root(&p);
deleteStringBuf();
POST_GC();
return s;
}
extern void *Bclosure (int bn, void *entry, ...) {
va_list args;
int i, ai;
register int *ebp asm("ebp");
size_t *argss;
data *r;
int n = UNBOX(bn);
PRE_GC();
argss = (ebp + 12);
for (i = 0; i < n; i++, argss++) { push_extra_root((void **)argss); }
r = (data *)alloc_closure(n + 1);
push_extra_root(&r);
((void **)r->contents)[0] = entry;
va_start(args, entry);
for (i = 0; i < n; i++) {
ai = va_arg(args, int);
((int *)r->contents)[i + 1] = ai;
}
va_end(args);
POST_GC();
pop_extra_root(&r);
argss--;
for (i = 0; i < n; i++, argss--) { pop_extra_root((void **)argss); }
return r->contents;
}
extern void *Barray (int bn, ...) {
va_list args;
int i, ai;
data *r;
int n = UNBOX(bn);
PRE_GC();
r = (data *)alloc_array(n);
va_start(args, bn);
for (i = 0; i < n; i++) {
ai = va_arg(args, int);
((int *)r->contents)[i] = ai;
}
va_end(args);
POST_GC();
return r->contents;
}
#ifdef DEBUG_VERSION
extern memory_chunk heap;
#endif
extern void *Bsexp (int bn, ...) {
va_list args;
int i;
int ai;
size_t *p;
data *r;
int n = UNBOX(bn);
PRE_GC();
int fields_cnt = n - 1;
r = (data *)alloc_sexp(fields_cnt);
((sexp *)r)->tag = 0;
va_start(args, bn);
for (i = 1; i < n; i++) {
ai = va_arg(args, int);
p = (size_t *)ai;
((int *)r->contents)[i] = ai;
}
((sexp *)r)->tag = UNBOX(va_arg(args, int));
va_end(args);
POST_GC();
return (int *)r->contents;
}
extern int Btag (void *d, int t, int n) {
data *r;
if (UNBOXED(d)) return BOX(0);
else {
r = TO_DATA(d);
return BOX(TAG(r->data_header) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t)
&& LEN(r->data_header) == UNBOX(n));
}
}
int get_tag (data *d) { return TAG(d->data_header); }
int get_len (data *d) { return LEN(d->data_header); }
extern int Barray_patt (void *d, int n) {
data *r;
if (UNBOXED(d)) return BOX(0);
else {
r = TO_DATA(d);
return BOX(get_tag(r) == ARRAY_TAG && get_len(r) == UNBOX(n));
}
}
extern int Bstring_patt (void *x, void *y) {
data *rx = (data *)BOX(NULL), *ry = (data *)BOX(NULL);
ASSERT_STRING(".string_patt:2", y);
if (UNBOXED(x)) return BOX(0);
else {
rx = TO_DATA(x);
ry = TO_DATA(y);
if (TAG(rx->data_header) != STRING_TAG) return BOX(0);
return BOX(strcmp(rx->contents, ry->contents) == 0 ? 1 : 0);
}
}
extern int Bclosure_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->data_header) == CLOSURE_TAG);
}
extern int Bboxed_patt (void *x) { return BOX(UNBOXED(x) ? 0 : 1); }
extern int Bunboxed_patt (void *x) { return BOX(UNBOXED(x) ? 1 : 0); }
extern int Barray_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->data_header) == ARRAY_TAG);
}
extern int Bstring_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->data_header) == STRING_TAG);
}
extern int Bsexp_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->data_header) == SEXP_TAG);
}
extern void *Bsta (void *v, int i, void *x) {
if (UNBOXED(i)) {
ASSERT_BOXED(".sta:3", x);
data *d = TO_DATA(x);
switch (TAG(d->data_header)) {
case STRING_TAG: {
((char *)x)[UNBOX(i)] = (char)UNBOX(v);
break;
}
case SEXP_TAG: {
((int *)x)[UNBOX(i) + 1] = (int)v;
break;
}
default: {
((int *)x)[UNBOX(i)] = (int)v;
}
}
} else {
*(void **)x = v;
}
return v;
}
static void fix_unboxed (char *s, va_list va) {
size_t *p = (size_t *)va;
int i = 0;
while (*s) {
if (*s == '%') {
size_t n = p[i];
if (UNBOXED(n)) { p[i] = UNBOX(n); }
i++;
}
s++;
}
}
extern void Lfailure (char *s, ...) {
va_list args;
va_start(args, s);
fix_unboxed(s, args);
vfailure(s, args);
}
extern void Bmatch_failure (void *v, char *fname, int line, int col) {
createStringBuf();
printValue(v);
failure("match failure at %s:%d:%d, value '%s'\n",
fname,
UNBOX(line),
UNBOX(col),
stringBuf.contents);
}
extern void * /*Lstrcat*/ Li__Infix_4343 (void *a, void *b) {
data *da = (data *)BOX(NULL);
data *db = (data *)BOX(NULL);
data *d = (data *)BOX(NULL);
ASSERT_STRING("++:1", a);
ASSERT_STRING("++:2", b);
da = TO_DATA(a);
db = TO_DATA(b);
PRE_GC();
push_extra_root(&a);
push_extra_root(&b);
d = alloc_string(LEN(da->data_header) + LEN(db->data_header));
pop_extra_root(&b);
pop_extra_root(&a);
da = TO_DATA(a);
db = TO_DATA(b);
strncpy(d->contents, da->contents, LEN(da->data_header));
strncpy(d->contents + LEN(da->data_header), db->contents, LEN(db->data_header));
d->contents[LEN(da->data_header) + LEN(db->data_header)] = 0;
POST_GC();
return d->contents;
}
extern void *Lsprintf (char *fmt, ...) {
va_list args;
void *s;
ASSERT_STRING("sprintf:1", fmt);
va_start(args, fmt);
fix_unboxed(fmt, args);
createStringBuf();
vprintStringBuf(fmt, args);
PRE_GC();
push_extra_root((void **)&fmt);
s = Bstring(stringBuf.contents);
pop_extra_root((void **)&fmt);
POST_GC();
deleteStringBuf();
return s;
}
extern void *LgetEnv (char *var) {
char *e = getenv(var);
void *s;
if (e == NULL) return (void *)BOX(0);
PRE_GC();
s = Bstring(e);
POST_GC();
return s;
}
extern int Lsystem (char *cmd) { return BOX(system(cmd)); }
extern void Lfprintf (FILE *f, char *s, ...) {
va_list args = (va_list)BOX(NULL);
ASSERT_BOXED("fprintf:1", f);
ASSERT_STRING("fprintf:2", s);
va_start(args, s);
fix_unboxed(s, args);
if (vfprintf(f, s, args) < 0) { failure("fprintf (...): %s\n", strerror(errno)); }
}
extern void Lprintf (char *s, ...) {
va_list args = (va_list)BOX(NULL);
ASSERT_STRING("printf:1", s);
va_start(args, s);
fix_unboxed(s, args);
if (vprintf(s, args) < 0) { failure("fprintf (...): %s\n", strerror(errno)); }
fflush(stdout);
}
extern FILE *Lfopen (char *f, char *m) {
FILE *h;
ASSERT_STRING("fopen:1", f);
ASSERT_STRING("fopen:2", m);
h = fopen(f, m);
if (h) return h;
failure("fopen (\"%s\", \"%s\"): %s, %s, %s\n", f, m, strerror(errno));
}
extern void Lfclose (FILE *f) {
ASSERT_BOXED("fclose", f);
fclose(f);
}
extern void *LreadLine () {
char *buf;
if (scanf("%m[^\n]", &buf) == 1) {
void *s = Bstring(buf);
getchar();
free(buf);
return s;
}
if (errno != 0) failure("readLine (): %s\n", strerror(errno));
return (void *)BOX(0);
}
extern void *Lfread (char *fname) {
FILE *f;
ASSERT_STRING("fread", fname);
f = fopen(fname, "r");
if (f) {
if (fseek(f, 0l, SEEK_END) >= 0) {
long size = ftell(f);
void *s = LmakeString(BOX(size));
rewind(f);
if (fread(s, 1, size, f) == size) {
fclose(f);
return s;
}
}
}
failure("fread (\"%s\"): %s\n", fname, strerror(errno));
}
extern void Lfwrite (char *fname, char *contents) {
FILE *f;
ASSERT_STRING("fwrite:1", fname);
ASSERT_STRING("fwrite:2", contents);
f = fopen(fname, "w");
if (f) {
if (fprintf(f, "%s", contents) < 0)
;
else {
fclose(f);
return;
}
}
failure("fwrite (\"%s\"): %s\n", fname, strerror(errno));
}
extern void *Lfexists (char *fname) {
FILE *f;
ASSERT_STRING("fexists", fname);
f = fopen(fname, "r");
if (f) return (void *)BOX(1);
return (void *)BOX(0);
}
extern void *Lfst (void *v) { return Belem(v, BOX(0)); }
extern void *Lsnd (void *v) { return Belem(v, BOX(1)); }
extern void *Lhd (void *v) { return Belem(v, BOX(0)); }
extern void *Ltl (void *v) { return Belem(v, BOX(1)); }
/* Lread is an implementation of the "read" construct */
extern int Lread () {
int result = BOX(0);
printf("> ");
fflush(stdout);
scanf("%d", &result);
return BOX(result);
}
extern int Lbinoperror (void) {
/* fprintf(stderr, "ERROR: POINTER ARITHMETICS is forbidden; EXIT\n");
exit(1);*/
}
extern int Lbinoperror2 (void) {
/* fprintf(stderr, "ERROR: Comparing BOXED and UNBOXED value ; EXIT\n");
exit(1);*/
}
/* Lwrite is an implementation of the "write" construct */
extern int Lwrite (int n) {
printf("%d\n", UNBOX(n));
fflush(stdout);
return 0;
}
extern int Lrandom (int n) {
ASSERT_UNBOXED("Lrandom, 0", n);
if (UNBOX(n) <= 0) { failure("invalid range in random: %d\n", UNBOX(n)); }
return BOX(random() % UNBOX(n));
}
extern int Ltime () {
struct timespec t;
clock_gettime(CLOCK_MONOTONIC_RAW, &t);
return BOX(t.tv_sec * 1000000 + t.tv_nsec / 1000);
}
extern void set_args (int argc, char *argv[]) {
data *a;
int n = argc;
int *p = NULL;
int i;
PRE_GC();
p = LmakeArray(BOX(n));
push_extra_root((void **)&p);
for (i = 0; i < n; i++) { ((int *)p)[i] = (int)Bstring(argv[i]); }
pop_extra_root((void **)&p);
POST_GC();
global_sysargs = p;
push_extra_root((void **)&global_sysargs);
}
/* GC starts here */
static int enable_GC = 1;
extern void LenableGC () { enable_GC = 1; }
extern void LdisableGC () { enable_GC = 0; }
Reference in a new issue View git blame Copy permalink