mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
424 lines
8.5 KiB
C
424 lines
8.5 KiB
C
# include <stdio.h>
|
|
# include <stdlib.h>
|
|
# include <stdarg.h>
|
|
# include <string.h>
|
|
|
|
# define UNBOXED(x) (((int) (x)) & 0x0001)
|
|
# define UNBOX(x) (((int) (x)) >> 1)
|
|
# define BOX(x) ((((int) (x)) << 1) | 0x0001)
|
|
|
|
# define STRING_TAG 0x00000001
|
|
# define ARRAY_TAG 0x00000003
|
|
# define SEXP_TAG 0x00000005
|
|
# define CLOSURE_TAG 0x00000007
|
|
# define UNBOXED_TAG 0x00000009 // Not actually a tag; used to return from LkindOf
|
|
|
|
# define LEN(x) ((x & 0xFFFFFFF8) >> 3)
|
|
# define TAG(x) (x & 0x00000007)
|
|
|
|
# define TO_DATA(x) ((data*)((char*)(x)-sizeof(int)))
|
|
# define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int)))
|
|
|
|
# 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)->tag) \
|
|
!= STRING_TAG) failure ("string value expected in %s\n", memo); while (0)
|
|
|
|
typedef struct {
|
|
int tag;
|
|
char contents[0];
|
|
} data;
|
|
|
|
typedef struct {
|
|
int tag;
|
|
data contents;
|
|
} sexp;
|
|
|
|
static char* chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'";
|
|
|
|
extern char* de_hash (int);
|
|
|
|
char* de_hash (int n) {
|
|
// static char *chars = (char*) BOX (NULL);
|
|
static char buf[6] = {0,0,0,0,0,0};
|
|
char *p = (char *) BOX (NULL);
|
|
p = &buf[5];
|
|
|
|
#ifdef DEBUG_PRINT
|
|
indent++; print_indent ();
|
|
printf ("de_hash: tag: %d\n", n); fflush (stdout);
|
|
#endif
|
|
|
|
*p-- = 0;
|
|
|
|
while (n != 0) {
|
|
#ifdef DEBUG_PRINT
|
|
print_indent ();
|
|
printf ("char: %c\n", chars [n & 0x003F]); fflush (stdout);
|
|
#endif
|
|
*p-- = chars [n & 0x003F];
|
|
n = n >> 6;
|
|
}
|
|
|
|
#ifdef DEBUG_PRINT
|
|
indent--;
|
|
#endif
|
|
|
|
return ++p;
|
|
}
|
|
|
|
int Blength (void *p) {
|
|
data *a = TO_DATA(p);
|
|
return BOX(LEN(a->tag));
|
|
}
|
|
|
|
extern void* Bsexp (int bn, ...) {
|
|
va_list args;
|
|
int i;
|
|
int ai;
|
|
size_t *p;
|
|
sexp *r;
|
|
data *d;
|
|
int n = UNBOX(bn);
|
|
|
|
r = (sexp*) malloc (sizeof(int) * (n+1));
|
|
d = &(r->contents);
|
|
r->tag = 0;
|
|
|
|
d->tag = SEXP_TAG | ((n-1) << 3);
|
|
|
|
va_start(args, bn);
|
|
|
|
for (i=0; i<n-1; i++) {
|
|
ai = va_arg(args, int);
|
|
|
|
p = (size_t*) ai;
|
|
((int*)d->contents)[i] = ai;
|
|
}
|
|
|
|
r->tag = UNBOX(va_arg(args, int));
|
|
|
|
va_end(args);
|
|
|
|
return d->contents;
|
|
}
|
|
|
|
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);
|
|
|
|
r = (data*) malloc (sizeof(int) * (n+2));
|
|
|
|
r->tag = CLOSURE_TAG | ((n + 1) << 3);
|
|
((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);
|
|
|
|
return r->contents;
|
|
}
|
|
|
|
|
|
void* Barray (int n0, ...) {
|
|
int n = UNBOX(n0);
|
|
va_list args;
|
|
int i, ai;
|
|
data *r;
|
|
|
|
r = (data*) malloc (sizeof(int) * (n+1));
|
|
|
|
r->tag = ARRAY_TAG | (n << 3);
|
|
|
|
va_start(args, n);
|
|
|
|
for (i = 0; i<n; i++) {
|
|
ai = va_arg(args, int);
|
|
((int*) r->contents)[i] = ai;
|
|
}
|
|
|
|
va_end(args);
|
|
|
|
return r->contents;
|
|
}
|
|
|
|
void* Bstring (void *p) {
|
|
int n = strlen (p);
|
|
data *s;
|
|
|
|
s = (data*) malloc (n + 1 + sizeof (int));
|
|
s->tag = STRING_TAG | (n << 3);
|
|
|
|
strncpy (s->contents, p, n + 1);
|
|
return s->contents;
|
|
}
|
|
|
|
void* Belem (void *p, int i0) {
|
|
int i = UNBOX(i0);
|
|
data *a = TO_DATA(p);
|
|
|
|
if (TAG(a->tag) == STRING_TAG) {
|
|
return (void*) BOX(a->contents[i]);
|
|
}
|
|
|
|
return (void*) ((int*) a->contents)[i];
|
|
}
|
|
|
|
void* Bsta (int i0, void *v, void *x) {
|
|
int i = UNBOX (i0);
|
|
|
|
if (TAG(TO_DATA(x)->tag) == STRING_TAG)
|
|
((char*) x)[i] = UNBOX((int) v);
|
|
else ((int*) x)[i] = (int) v;
|
|
|
|
return v;
|
|
}
|
|
|
|
extern int Btag (void *d, int t, int n) {
|
|
data *r;
|
|
|
|
if (UNBOXED(d)) return BOX(0);
|
|
else {
|
|
r = TO_DATA(d);
|
|
#ifndef DEBUG_PRINT
|
|
return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t) && LEN(r->tag) == UNBOX(n));
|
|
#else
|
|
return BOX(TAG(r->tag) == SEXP_TAG &&
|
|
GET_SEXP_TAG(TO_SEXP(d)->tag) == UNBOX(t) && LEN(r->tag) == UNBOX(n));
|
|
#endif
|
|
}
|
|
}
|
|
|
|
extern int Barray_patt (void *d, int n) {
|
|
data *r;
|
|
|
|
if (UNBOXED(d)) return BOX(0);
|
|
else {
|
|
r = TO_DATA(d);
|
|
return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == UNBOX(n));
|
|
}
|
|
}
|
|
|
|
static void failure (char *s, ...);
|
|
|
|
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->tag) != STRING_TAG) return BOX(0);
|
|
|
|
return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0);
|
|
}
|
|
}
|
|
|
|
void Lwrite (int x) {
|
|
printf ("%d\n", UNBOX (x));
|
|
}
|
|
|
|
int Lread () {
|
|
int result;
|
|
|
|
scanf ("%d", &result);
|
|
|
|
return BOX(result);
|
|
}
|
|
|
|
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);
|
|
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);
|
|
|
|
again:
|
|
buf = &stringBuf.contents[stringBuf.ptr];
|
|
rest = stringBuf.len - stringBuf.ptr;
|
|
written = vsnprintf (buf, rest, fmt, args);
|
|
|
|
if (written >= rest) {
|
|
extendStringBuf ();
|
|
goto again;
|
|
}
|
|
|
|
stringBuf.ptr += written;
|
|
}
|
|
|
|
static void printStringBuf (char *fmt, ...) {
|
|
va_list args;
|
|
|
|
va_start (args, fmt);
|
|
vprintStringBuf (fmt, args);
|
|
}
|
|
|
|
|
|
int is_valid_heap_pointer (void *p) {
|
|
return 1;
|
|
}
|
|
|
|
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->tag)) {
|
|
case STRING_TAG:
|
|
printStringBuf ("\"%s\"", a->contents);
|
|
break;
|
|
|
|
case CLOSURE_TAG:
|
|
printStringBuf ("<closure ");
|
|
for (i = 0; i < LEN(a->tag); i++) {
|
|
if (i) printValue ((void*)((int*) a->contents)[i]);
|
|
else printStringBuf ("0x%x", (void*)((int*) a->contents)[i]);
|
|
|
|
if (i != LEN(a->tag) - 1) printStringBuf (", ");
|
|
}
|
|
printStringBuf (">");
|
|
break;
|
|
|
|
case ARRAY_TAG:
|
|
printStringBuf ("[");
|
|
for (i = 0; i < LEN(a->tag); i++) {
|
|
printValue ((void*)((int*) a->contents)[i]);
|
|
if (i != LEN(a->tag) - 1) printStringBuf (", ");
|
|
}
|
|
printStringBuf ("]");
|
|
break;
|
|
|
|
case SEXP_TAG: {
|
|
#ifndef DEBUG_PRINT
|
|
char * tag = de_hash (TO_SEXP(p)->tag);
|
|
#else
|
|
char * tag = de_hash (GET_SEXP_TAG(TO_SEXP(p)->tag));
|
|
#endif
|
|
|
|
if (strcmp (tag, "cons") == 0) {
|
|
data *b = a;
|
|
|
|
printStringBuf ("{");
|
|
|
|
while (LEN(a->tag)) {
|
|
printValue ((void*)((int*) b->contents)[0]);
|
|
b = (data*)((int*) b->contents)[1];
|
|
if (! UNBOXED(b)) {
|
|
printStringBuf (", ");
|
|
b = TO_DATA(b);
|
|
}
|
|
else break;
|
|
}
|
|
|
|
printStringBuf ("}");
|
|
}
|
|
else {
|
|
printStringBuf ("%s", tag);
|
|
if (LEN(a->tag)) {
|
|
printStringBuf (" (");
|
|
for (i = 0; i < LEN(a->tag); i++) {
|
|
printValue ((void*)((int*) a->contents)[i]);
|
|
if (i != LEN(a->tag) - 1) printStringBuf (", ");
|
|
}
|
|
printStringBuf (")");
|
|
}
|
|
}
|
|
}
|
|
break;
|
|
|
|
default:
|
|
printStringBuf ("*** invalid tag: 0x%x ***", TAG(a->tag));
|
|
}
|
|
}
|
|
}
|
|
|
|
static void vfailure (char *s, va_list args) {
|
|
fprintf (stderr, "*** FAILURE: ");
|
|
vfprintf (stderr, s, args); // vprintf (char *, va_list) <-> printf (char *, ...)
|
|
exit (255);
|
|
}
|
|
|
|
static void failure (char *s, ...) {
|
|
va_list args;
|
|
|
|
va_start (args, s);
|
|
vfailure (s, args);
|
|
}
|
|
|
|
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);
|
|
}
|