/* Support for Lisp-style data. Copyright (C) 1991-2000 Stanley T. Shebs. Xconq is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. See the file COPYING. */ /* (should have some deallocation support, since some game init data can be discarded) */ #include "config.h" #include "misc.h" #include "lisp.h" /* Declarations of local functions. */ static Obj *newobj(void); static Symentry *lookup_string(char *str); static int hash_name(char *str); static int strmgetc(Strm *strm); static void strmungetc(int ch, Strm *strm); static void sprintf_context(char *buf, int n, int *start, int *end, Strm *strm); static Obj *read_form_aux(Strm *strm); static Obj *read_list(Strm *strm); static int read_delimited_text(Strm *strm, char *delim, int spacedelimits, int eofdelimits); static void internal_type_error(char *funname, Obj *x, char *typename); /* Pointer to "nil", the empty list. */ Obj *lispnil; /* Pointer to "eof", which is returned if no more forms in a file. */ Obj *lispeof; /* Pointer to a "closing paren" object used only during list reading. */ Obj *lispclosingparen; /* Pointer to an "unbound" object that indicates unbound variables. */ Obj *lispunbound; /* Current number of symbols in the symbol table. */ int numsymbols = 0; /* Pointer to the base of the symbol table itself. */ static Symentry **symboltablebase = NULL; /* The number of Lisp objects allocated so far. */ int lispmalloc = 0; /* This variable is used to track the depth of nested #| |# comments. */ int commentdepth = 0; int actually_read_lisp = TRUE; #define BIGBUF 1000 static char *lispstrbuf = NULL; static int *startlineno; static int *endlineno; static char *linenobuf; static char *escapedthingbuf; /* Allocate a new Lisp object, count it as such. */ static Obj * newobj(void) { lispmalloc += sizeof(Obj); return ((Obj *) xmalloc(sizeof(Obj))); } /* Pre-create some objects that should always exist. */ void init_lisp(void) { /* Allocate Lisp's NIL. */ lispnil = newobj(); lispnil->type = NIL; /* Do this so car/cdr of nil is nil, might cause infinite loops though. */ lispnil->v.cons.car = lispnil; lispnil->v.cons.cdr = lispnil; /* We use the eof object to recognize eof when reading a file. */ lispeof = newobj(); lispeof->type = EOFOBJ; /* The "closing paren" object just flags closing parens while reading. */ lispclosingparen = newobj(); /* The "unbound" object is for unbound variables. */ lispunbound = newobj(); /* Set up the symbol table. */ symboltablebase = (Symentry **) xmalloc(256 * sizeof(Symentry *)); numsymbols = 0; init_predefined_symbols(); escapedthingbuf = xmalloc(BUFSIZE); } /* Ultra-simple "streams" that can be stdio FILEs or strings. */ static int strmgetc(Strm *strm) { int ch; if (strm->type == stringstrm) { if (*(strm->ptr.sp) == '\0') ch = EOF; else ch = *((strm->ptr.sp)++); } else { ch = getc(strm->ptr.fp); /* Handle some non-english characters whose coding differ between unix and mac. This is required for the Swedish name generator to return non-garbage on the mac. Note 1: The signs that look like < and , are not the normal < and ,. Note 2: Typecasting ch to char is necessary here, but it must remain an int to handle EOF correctly on unix. */ #ifdef MAC if ((char) ch == 'Å') ch = ''; if ((char) ch == 'Ä') ch = '€'; if ((char) ch == 'Ö') ch = '…'; if ((char) ch == 'Ü') ch = '†'; if ((char) ch == 'å') ch = 'Œ'; if ((char) ch == 'ä') ch = 'Š'; if ((char) ch == 'ö') ch = 'š'; if ((char) ch == 'ü') ch = 'Ÿ'; #endif } if (ch != EOF) { ++(strm->numread); strm->lastread[(strm->numread % (CONTEXTSIZE - 1))] = ch; strm->lastread[((strm->numread + 1) % (CONTEXTSIZE - 1))] = '\0'; /* This is redundant unless we're at the end of the buffer. */ strm->lastread[(strm->numread % (CONTEXTSIZE - 1)) + 1] = '\0'; } return ch; } static void strmungetc(int ch, Strm *strm) { if (strm->type == stringstrm) { --strm->ptr.sp; } else { ungetc(ch, strm->ptr.fp); } --(strm->numread); } /* El cheapo Lisp reader. Lisp objects are generally advertised by their first characters, but lots of semantics actions happen while reading, so this isn't really a regular expression reader. */ Obj * read_form(FILE *fp, int *p1, int *p2) { Obj *rslt; Strm tmpstrm; commentdepth = 0; startlineno = p1; endlineno = p2; tmpstrm.type = filestrm; tmpstrm.ptr.fp = fp; tmpstrm.numread = 0; rslt = read_form_aux(&tmpstrm); if (rslt == lispclosingparen) { if (linenobuf == NULL) linenobuf = xmalloc(BUFSIZE); sprintf_context(linenobuf, BUFSIZE, startlineno, endlineno, &tmpstrm); init_warning("extra close paren, substituting nil%s", linenobuf); rslt = lispnil; } return rslt; } Obj * read_form_from_string(char *str, int *p1, int *p2, char **endstr) { Obj *rslt; Strm tmpstrm; commentdepth = 0; startlineno = p1; endlineno = p2; tmpstrm.type = stringstrm; tmpstrm.ptr.sp = str; tmpstrm.numread = 0; rslt = read_form_aux(&tmpstrm); if (rslt == lispclosingparen) { if (linenobuf == NULL) linenobuf = xmalloc(BUFSIZE); sprintf_context(linenobuf, BUFSIZE, startlineno, endlineno, &tmpstrm); init_warning("extra close paren, substituting nil%s", linenobuf); rslt = lispnil; } /* Record the next character to read from the string if possible. */ if (endstr != NULL) *endstr = tmpstrm.ptr.sp; return rslt; } static void sprintf_context(char *buf, int n, int *start, int *end, Strm *strm) { int printedlineno = FALSE; strcpy(buf, "("); if (start != NULL && end != NULL) { if (*start == *end) { sprintf(buf + strlen(buf), "at line %d", *start); } else { sprintf(buf + strlen(buf), "lines %d to %d", *start, *end); } printedlineno = TRUE; } if (!empty_string(strm->lastread)) { if (printedlineno) strcat(buf, ", "); strcat(buf, "context \""); if (strm->numread > (CONTEXTSIZE - 1) && (strm->numread % (CONTEXTSIZE - 1)) > 0) { strncpy(buf + strlen(buf), strm->lastread + (strm->numread % (CONTEXTSIZE - 1)), n - strlen(buf) - 1); } strncpy(buf + strlen(buf), strm->lastread, n - strlen(buf) - 1); buf[n - 1] = '\0'; strcat(buf, "\""); } strcat(buf, ")"); } /* The main body of the the Lisp reader, works from a stream and returns an object. */ static Obj * read_form_aux(Strm *strm) { int minus, factor, commentclosed, ch, ch2, ch3, ch4, num; int numdice, dice, indice; while ((ch = strmgetc(strm)) != EOF) { /* Recognize nested comments specially. */ if (ch == '#') { if ((ch2 = strmgetc(strm)) == '|') { commentclosed = FALSE; ++commentdepth; while ((ch3 = strmgetc(strm)) != EOF) { if (ch3 == '|') { /* try to recognize # */ if ((ch4 = strmgetc(strm)) == '#') { --commentdepth; if (commentdepth == 0) { commentclosed = TRUE; break; } } else { strmungetc(ch4, strm); } } else if (ch3 == '#') { if ((ch4 = strmgetc(strm)) == '|') { ++commentdepth; } else { strmungetc(ch4, strm); } } else if (ch3 == '\n') { if (endlineno != NULL) ++(*endlineno); announce_read_progress(); } } if (!commentclosed) { init_warning("comment not closed at eof"); } /* Always pick up the next char. */ ch = strmgetc(strm); } else { strmungetc(ch2, strm); return intern_symbol("#"); } } /* Regular lexical recognition. */ if (isspace(ch)) { /* Nothing to do here except count lines. */ if (ch == '\n') { if (endlineno != NULL) ++(*endlineno); if (startlineno != NULL) ++(*startlineno); announce_read_progress(); } } else if (ch == ';') { /* Discard all from here to the end of this line. */ while ((ch = strmgetc(strm)) != EOF && ch != '\n'); if (endlineno != NULL) ++(*endlineno); announce_read_progress(); } else if (ch == '(') { /* Jump into a list-reading mode. */ return read_list(strm); } else if (ch == ')') { /* This is just to flag the end of the list for read_list. */ return lispclosingparen; } else if (ch == '"') { read_delimited_text(strm, "\"", FALSE, FALSE); if (!actually_read_lisp) return lispnil; return new_string(copy_string(lispstrbuf)); } else if (ch == '|') { read_delimited_text(strm, "|", FALSE, FALSE); if (!actually_read_lisp) return lispnil; return intern_symbol(lispstrbuf); } else if (strchr("`'", ch)) { if (!actually_read_lisp) return lispnil; return cons(intern_symbol("quote"), cons(read_form_aux(strm), lispnil)); } else if (isdigit(ch) || ch == '-' || ch == '+' || ch == '.') { numdice = dice = 0; indice = FALSE; minus = (ch == '-'); factor = (ch == '.' ? 100 : 1); num = 0; if (isdigit(ch)) num = ch - '0'; while ((ch = strmgetc(strm)) != EOF) { if (isdigit(ch)) { /* should ignore decimal digits past second one */ num = num * 10 + ch - '0'; if (factor > 1) factor /= 10; } else if (ch == 'd') { numdice = num; num = 0; indice = TRUE; } else if (ch == '+' || ch == '-') { dice = num; num = 0; indice = FALSE; } else if (ch == '.') { factor = 100; } else { break; } } /* If number was followed by a % char, discard the char, otherwise put it back on the stream. */ if (ch != '%' && ch != EOF) strmungetc(ch, strm); if (indice) { dice = num; num = 0; } if (minus) num = 0 - num; if (numdice > 0) { /* Warn about out-of-bounds values. */ if (!between(0, numdice, 7)) init_warning("Number of dice in %dd%d+%d is %d, not between 0 and 7", numdice, dice, num, numdice); if (!between(0, dice, 15)) init_warning("Dice size in %dd%d+%d is %d, not between 0 and 15", numdice, dice, num, dice); if (!between(0, num, 127)) init_warning("Dice addon in %dd%d+%d is %d, not between 0 and 127", numdice, dice, num, num); num = (1 << 14) | (numdice << 11) | (dice << 7) | (num & 0x7f); } else { num = factor * num; } if (!actually_read_lisp) return lispnil; return new_number(num); } else { /* Read a regular symbol. */ /* The char we just looked will be the first char. */ strmungetc(ch, strm); /* Now read until any special char seen. */ ch = read_delimited_text(strm, "();\"'`#", TRUE, TRUE); /* Undo the extra char we read in order to detect the end of the symbol. */ strmungetc(ch, strm); /* Need to recognize nil specially here. */ if (strcmp("nil", lispstrbuf) == 0) { return lispnil; } else if (!actually_read_lisp) { /* Recognize boundaries of non-reading specially. */ if (strcmp("else", lispstrbuf) == 0) return intern_symbol(lispstrbuf); if (strcmp("end-if", lispstrbuf) == 0) return intern_symbol(lispstrbuf); return lispnil; } else { return intern_symbol(lispstrbuf); } } } return lispeof; } /* Read a sequence of expressions terminated by a closing paren. This works by looping; although recursion is more elegant, if the compiler does not turn tail-recursion into loops, long lists can blow the stack. (This has happened with real saved games.) */ static Obj * read_list(Strm *strm) { Obj *thecar, *thenext, *lis, *endlis; thecar = read_form_aux(strm); if (thecar == lispclosingparen) { return lispnil; } else if (thecar == lispeof) { goto at_eof; } else { lis = cons(thecar, lispnil); endlis = lis; while (TRUE) { thenext = read_form_aux(strm); if (thenext == lispclosingparen) { break; } else if (thenext == lispeof) { goto at_eof; } else { set_cdr(endlis, cons(thenext, lispnil)); endlis = cdr(endlis); } } return lis; } at_eof: if (linenobuf == NULL) linenobuf = xmalloc(BUFSIZE); sprintf_context(linenobuf, BUFSIZE, startlineno, endlineno, strm); init_warning("missing a close paren, returning EOF%s", linenobuf); return lispeof; } /* Read a quantity of text delimited by a char from the given string, possibly also by whitespace or EOF. */ static int read_delimited_text(Strm *strm, char *delim, int spacedelimits, int eofdelimits) { int ch, octch, j = 0, warned = FALSE; if (lispstrbuf == NULL) lispstrbuf = (char *) xmalloc(BIGBUF); while ((ch = strmgetc(strm)) != EOF && (!spacedelimits || !isspace(ch)) && !strchr(delim, ch)) { /* Handle escape char by replacing with next char, or maybe interpret an octal sequence. */ if (ch == '\\') { ch = strmgetc(strm); /* Octal chars introduced by a leading zero. */ if (ch == '0') { octch = 0; /* Soak up numeric digits (don't complain about 8 or 9, sloppy but traditional). */ while ((ch = strmgetc(strm)) != EOF && isdigit(ch)) { octch = 8 * octch + ch - '0'; } /* The non-digit char is actually next one in the string. */ strmungetc(ch, strm); ch = octch; } } if (j >= BIGBUF) { /* Warn about buffer overflow, but only once per string, then still read chars but discard them. */ if (!warned) { init_warning( "exceeded max sym/str length (%d chars), ignoring rest", BIGBUF); warned = TRUE; } } else { lispstrbuf[j++] = ch; } } lispstrbuf[j] = '\0'; return ch; } /* The usual list length function. */ int length(Obj *list) { int rslt = 0; while (list != lispnil) { list = cdr(list); ++rslt; } return rslt; } /* Basic allocation routines. */ Obj * new_string(char *str) { Obj *new = newobj(); new->type = STRING; new->v.str = str; return new; } Obj * new_number(int num) { Obj *new = newobj(); new->type = NUMBER; new->v.num = num; return new; } Obj * new_utype(int u) { Obj *new = newobj(); new->type = UTYPE; new->v.num = u; return new; } Obj * new_mtype(int m) { Obj *new = newobj(); new->type = MTYPE; new->v.num = m; return new; } Obj * new_ttype(int t) { Obj *new = newobj(); new->type = TTYPE; new->v.num = t; return new; } Obj * new_atype(int a) { Obj *new = newobj(); new->type = ATYPE; new->v.num = a; return new; } Obj * new_pointer(Obj *sym, char *ptr) { Obj *new = newobj(); new->type = POINTER; new->v.ptr.sym = sym; new->v.ptr.data = ptr; return new; } Obj * cons(Obj *x, Obj *y) { Obj *new = newobj(); new->type = CONS; new->v.cons.car = x; new->v.cons.cdr = y; /* Xconq's Lisp does not include dot notation for consing, so this can only happen if there is an internal error somewhere. */ if (!listp(y)) run_error("cdr of cons is not a list"); return new; } void type_warning(char *funname, Obj *x, char *typename, Obj *subst) { char buf1[BUFSIZE], buf2[BUFSIZE]; sprintlisp(buf1, x, BUFSIZE); sprintlisp(buf2, subst, BUFSIZE); run_warning("%s of non-%s `%s' being taken, returning `%s' instead", funname, typename, buf1, buf2); } /* This routine reports fatal errors with handling objects. */ static void internal_type_error(char *funname, Obj *x, char *typename) { char buf1[BUFSIZE]; sprintlisp(buf1, x, BUFSIZE); run_error("%s of non-%s `%s'", funname, typename, buf1); } /* The usual suspects. */ Obj * car(Obj *x) { if (x->type == CONS || x->type == NIL) { return x->v.cons.car; } else { internal_type_error("car", x, "list"); return lispnil; } } Obj * cdr(Obj *x) { if (x->type == CONS || x->type == NIL) { return x->v.cons.cdr; } else { internal_type_error("cdr", x, "list"); return lispnil; } } Obj * cadr(Obj *x) { return car(cdr(x)); } Obj * cddr(Obj *x) { return cdr(cdr(x)); } Obj * caddr(Obj *x) { return car(cdr(cdr(x))); } Obj * cdddr(Obj *x) { return cdr(cdr(cdr(x))); } void set_cdr(Obj *x, Obj *v) { if (x->type == CONS) { x->v.cons.cdr = v; } else { internal_type_error("set_cdr", x, "cons"); } } /* Return the string out of both strings and symbols. */ char * c_string(Obj *x) { if (x->type == STRING) { return x->v.str; } else if (x->type == SYMBOL) { return x->v.sym.symentry->name; } else { /* (should be internal_type_error?) */ type_warning("c_string", x, "string/symbol", lispnil); return ""; } } /* Return the actual number in a number object. */ int c_number(Obj *x) { if (x->type == NUMBER || x->type == UTYPE || x->type == MTYPE || x->type == TTYPE || x->type == ATYPE) { return x->v.num; } else { /* (should be internal_type_error?) */ type_warning("c_number", x, "number", lispnil); return 0; } } Obj * intern_symbol(char *str) { int n; Symentry *se; Obj *new1; se = lookup_string(str); if (se) { return se->symbol; } else { new1 = newobj(); new1->type = SYMBOL; se = (Symentry *) xmalloc(sizeof(Symentry)); new1->v.sym.symentry = se; /* Declare a newly created symbol to be unbound. */ new1->v.sym.value = lispunbound; se->name = copy_string(str); se->symbol = new1; se->constantp = FALSE; n = hash_name(str); /* Push the symbol entry onto the front of its hash bucket. */ se->next = symboltablebase[n]; symboltablebase[n] = se; ++numsymbols; return new1; } } /* Given a string, try to find a symbol entry with that as its name. */ static Symentry * lookup_string(char *str) { Symentry *se; for (se = symboltablebase[hash_name(str)]; se != NULL; se = se->next) { if (strcmp(se->name, str) == 0) return se; } return NULL; } static int hash_name(char *str) { int rslt = 0; while (*str != '\0') rslt ^= *str++; return (ABS(rslt) & 0xff); } Obj * symbol_value(Obj *sym) { Obj *val = sym->v.sym.value; if (val == lispunbound) { run_warning("unbound symbol `%s', substituting nil", c_string(sym)); val = lispnil; } return val; } Obj * setq(Obj *sym, Obj *x) { /* All the callers check for symbolness, but be careful. */ if (!symbolp(sym)) { internal_type_error("setq", sym, "symbol"); } if (constantp(sym)) { run_warning("Can't alter the constant `%s', ignoring attempt", c_string(sym)); return x; } sym->v.sym.value = x; return x; } void makunbound(Obj *sym) { sym->v.sym.value = lispunbound; } void flag_as_constant(Obj *sym) { sym->v.sym.symentry->constantp = TRUE; } int constantp(Obj *sym) { return (sym->v.sym.symentry->constantp); } int numberp(Obj *x) { return (x->type == NUMBER); } int stringp(Obj *x) { return (x->type == STRING); } int symbolp(Obj *x) { return (x->type == SYMBOL); } int consp(Obj *x) { return (x->type == CONS); } int utypep(Obj *x) { return (x->type == UTYPE); } int mtypep(Obj *x) { return (x->type == MTYPE); } int ttypep(Obj *x) { return (x->type == TTYPE); } int atypep(Obj *x) { return (x->type == ATYPE); } int pointerp(Obj *x) { return (x->type == POINTER); } int boundp(Obj *sym) { return (sym->v.sym.value != lispunbound); } int numberishp(Obj *x) { return (x->type == NUMBER || x->type == UTYPE || x->type == MTYPE || x->type == TTYPE || x->type == ATYPE); } int listp(Obj *x) { return (x->type == NIL || x->type == CONS); } /* General structural equality test. Assumes that it is not getting passed any circular structures, which should never happen in Xconq. */ int equal(Obj *x, Obj *y) { /* Objects of different types can never be equal. */ if (x->type != y->type) return FALSE; /* Identical objects are always equal. */ if (x == y) return TRUE; switch (x->type) { case NUMBER: case UTYPE: case MTYPE: case TTYPE: case ATYPE: return (c_number(x) == c_number(y)); case STRING: return (strcmp(c_string(x), c_string(y)) == 0); case SYMBOL: return (strcmp(c_string(x), c_string(y)) == 0); case CONS: return (equal(car(x), car(y)) && equal(cdr(x), cdr(y))); case POINTER: return FALSE; default: case_panic("lisp type", x->type); return FALSE; } } int member(Obj *x, Obj *lis) { if (lis == lispnil) { return FALSE; } else if (!consp(lis)) { /* should probably be an error of some sort */ return FALSE; } else if (equal(x, car(lis))) { return TRUE; } else { return member(x, cdr(lis)); } } /* Return the nth element of a list. */ Obj * elt(Obj *lis, int n) { while (n-- > 0) { lis = cdr(lis); } return car(lis); } Obj * reverse(Obj *lis) { Obj *rslt = lispnil; for (; lis != lispnil; lis = cdr(lis)) { rslt = cons(car(lis), rslt); } return rslt; } Obj * find_at_key(Obj *lis, char *key) { Obj *rest, *bdgs, *bdg; for_all_list(lis, rest) { bdgs = car(rest); bdg = car(bdgs); if (stringp(bdg) && strcmp(key, c_string(bdg)) == 0) { return cdr(bdgs); } } return lispnil; } Obj * replace_at_key(Obj *lis, char *key, Obj *newval) { Obj *rest, *bdgs, *bdg; for_all_list(lis, rest) { bdgs = car(rest); bdg = car(bdgs); if (stringp(bdg) && strcmp(key, c_string(bdg)) == 0) { set_cdr(bdgs, newval); return lis; } } return cons(cons(new_string(key), newval), lis); } void fprintlisp(FILE *fp, Obj *obj) { int needescape; char *str, *tmp; /* Doublecheck, just in case caller is not so careful. */ if (obj == NULL) { run_warning("Trying to print NULL as object, skipping"); return; } switch (obj->type) { case NIL: fprintf(fp, "nil"); break; case NUMBER: fprintf(fp, "%d", obj->v.num); break; case STRING: if (strchr(obj->v.str, '"')) { fprintf(fp, "\""); for (tmp = obj->v.str; *tmp != '\0'; ++tmp) { if (*tmp == '"') fprintf(fp, "\\"); fprintf(fp, "%c", *tmp); } fprintf(fp, "\""); } else { /* Just printf the whole string. */ fprintf(fp, "\"%s\"", obj->v.str); } break; case SYMBOL: needescape = FALSE; str = c_string(obj); if (isdigit(str[0])) { needescape = TRUE; } else { /* Scan the symbol's name looking for special chars. */ for (tmp = str; *tmp != '\0'; ++tmp) { if (strchr(" ()#\";|", *tmp)) { needescape = TRUE; break; } } } if (needescape) { fprintf(fp, "|%s|", str); } else { fprintf(fp, "%s", str); } break; case CONS: fprintf(fp, "("); fprintlisp(fp, car(obj)); /* Note that there are no dotted pairs in our version of Lisp. */ fprint_list(fp, cdr(obj)); break; case UTYPE: fprintf(fp, "u#%d", obj->v.num); break; case MTYPE: fprintf(fp, "m#%d", obj->v.num); break; case TTYPE: fprintf(fp, "t#%d", obj->v.num); break; case ATYPE: fprintf(fp, "a#%d", obj->v.num); break; case POINTER: fprintlisp(fp, obj->v.ptr.sym); fprintf(fp, " #|0x%lx|#", (long) obj->v.ptr.data); break; default: case_panic("lisp type", obj->type); break; } } void fprint_list(FILE *fp, Obj *obj) { Obj *tmp; for_all_list(obj, tmp) { fprintf(fp, " "); fprintlisp(fp, car(tmp)); } fprintf(fp, ")"); } void sprintlisp(char *buf, Obj *obj, int maxlen) { if (maxlen < 10) { strcpy(buf, " ... "); return; } switch (obj->type) { case NIL: strcpy(buf, "nil"); break; case NUMBER: sprintf(buf, "%d", obj->v.num); break; case STRING: if (maxlen < (strlen(obj->v.str) + 2)) { strcpy(buf, " ... "); return; } /* (should print escape chars if needed) */ sprintf(buf, "\"%s\"", obj->v.str); break; case SYMBOL: if (maxlen < strlen(c_string(obj))) { strcpy(buf, " ... "); return; } /* (should print escape chars if needed) */ sprintf(buf, "%s", c_string(obj)); break; case CONS: strcpy(buf, "("); sprintlisp(buf + 1, car(obj), maxlen - 1); /* No dotted pairs allowed in our version of Lisp. */ sprint_list(buf+strlen(buf), cdr(obj), maxlen - strlen(buf)); break; case UTYPE: sprintf(buf, "u#%d", obj->v.num); break; case MTYPE: sprintf(buf, "m#%d", obj->v.num); break; case TTYPE: sprintf(buf, "t#%d", obj->v.num); break; case ATYPE: sprintf(buf, "a#%d", obj->v.num); break; case POINTER: sprintlisp(buf, obj->v.ptr.sym, maxlen); sprintf(buf+strlen(buf), " #|0x%lx|#", (long) obj->v.ptr.data); break; default: case_panic("lisp type", obj->type); break; } } void sprint_list(char *buf, Obj *obj, int maxlen) { Obj *tmp; buf[0] = '\0'; for (tmp = obj; tmp != lispnil; tmp = cdr(tmp)) { if ((maxlen - strlen(buf)) < 10) { strcpy(buf, " ... "); break; } strcat(buf, " "); sprintlisp(buf+strlen(buf), car(tmp), maxlen - strlen(buf)); } strcat(buf, ")"); } /* These two routines make sure that any symbols and strings can be read in again. */ char * escaped_symbol(char *str) { char *tmp = str; if (str[0] == '|' && str[strlen(str)-1] == '|') return str; if (isdigit(str[0])) { sprintf(escapedthingbuf, "|%s|", str); return escapedthingbuf; } while (*tmp != '\0') { if (((char *) strchr(" ()#\";|", *tmp)) != NULL) { sprintf(escapedthingbuf, "|%s|", str); return escapedthingbuf; } ++tmp; } return str; } /* Note that this works correctly on NULL strings, turning them into strings of length 0. */ char * escaped_string(char *str) { char *tmp = str, *rslt = escapedthingbuf; *rslt++ = '"'; if (str != NULL) { while (*tmp != 0) { if (*tmp == '"') *rslt++ = '\\'; *rslt++ = *tmp++; } } *rslt++ = '"'; *rslt = '\0'; return escapedthingbuf; } #ifdef DEBUGGING /* For calling from debuggers, at least that those that support output to stderr. */ void dlisp(Obj *x) { fprintlisp(stderr, x); fprintf(stderr, "\n"); } #endif /* DEBUGGING */ void print_form_and_value(FILE *fp, Obj *form) { fprintlisp(fp, form); if (symbolp(form)) { if (boundp(form)) { fprintf(fp, " -> "); fprintlisp(fp, symbol_value(form)); } else { fprintf(fp, " "); } } fprintf(fp, "\n"); } Obj * append_two_lists(Obj *x1, Obj *x2) { if (!listp(x1)) x1 = cons(x1, lispnil); if (!listp(x2)) x2 = cons(x2, lispnil); if (x2 == lispnil) { return x1; } else if (x1 == lispnil) { return x2; } else { return cons(car(x1), append_two_lists(cdr(x1), x2)); } } Obj * append_lists(Obj *lis) { if (lis == lispnil) { return lispnil; } else if (!consp(lis)) { return cons(lis, lispnil); } else { return append_two_lists(car(lis), append_lists(cdr(lis))); } } /* Remove all occurrences of a single object from a given list. */ Obj * remove_from_list(Obj *elt, Obj *lis) { Obj *tmp; if (lis == lispnil) { return lispnil; } else { tmp = remove_from_list(elt, cdr(lis)); if (equal(elt, car(lis))) { return tmp; } else { return cons(car(lis), tmp); } } } void push_binding(Obj **lis, Obj *key, Obj *val) { *lis = cons(cons(key, cons(val, lispnil)), *lis); } void push_cdr_binding(Obj **lis, Obj *key, Obj *val) { *lis = cons(cons(key, val), *lis); } void push_int_binding(Obj **lis, Obj *key, int val) { *lis = cons(cons(key, cons(new_number(val), lispnil)), *lis); } void push_key_binding(Obj **lis, int key, Obj *val) { *lis = cons(cons(intern_symbol(keyword_name(key)), cons(val, lispnil)), *lis); } void push_key_cdr_binding(Obj **lis, int key, Obj *val) { *lis = cons(cons(intern_symbol(keyword_name(key)), val), *lis); } void push_key_int_binding(Obj **lis, int key, int val) { *lis = cons(cons(intern_symbol(keyword_name(key)), cons(new_number(val), lispnil)), *lis); } /* Our version of evaluation derefs symbols and evals through lists, unless the list car is a "special form". */ Obj * eval(Obj *x) { int code; Obj *specialform; switch (x->type) { case SYMBOL: return eval_symbol(x); case CONS: specialform = car(x); if (symbolp(specialform) && !boundp(specialform) && (code = keyword_code(c_string(specialform))) >= 0) { switch (code) { case K_QUOTE: return cadr(x); case K_LIST: return eval_list(cdr(x)); case K_APPEND: return append_lists(eval_list(cdr(x))); case K_REMOVE: return remove_from_list(eval(cadr(x)), eval(caddr(x))); default: break; } } /* A dubious default, but convenient. */ return eval_list(x); default: /* Everything else evaluates to itself. */ return x; } } /* Some symbols are lazily bound, meaning that they don't get a value until it is first asked for. */ Obj * eval_symbol(Obj *sym) { if (boundp(sym)) { return symbol_value(sym); } else if (lazy_bind(sym)) { return symbol_value(sym); } else { run_warning("`%s' is unbound, returning self", c_string(sym)); /* kind of a hack */ return sym; } } /* List evaluation just blasts straight through the list. */ Obj * eval_list(Obj *lis) { if (lis == lispnil) { return lispnil; } else { return cons(eval(car(lis)), eval_list(cdr(lis))); } } int eval_boolean_expression(Obj *expr, int (*fn)(Obj *), int dflt) { char *opname; if (expr == lispnil) { return dflt; } else if (consp(expr) && symbolp(car(expr))) { opname = c_string(car(expr)); switch (keyword_code(opname)) { case K_AND: return (eval_boolean_expression(cadr(expr), fn, dflt) && eval_boolean_expression(car(cddr(expr)), fn, dflt)); case K_OR: return (eval_boolean_expression(cadr(expr), fn, dflt) || eval_boolean_expression(car(cddr(expr)), fn, dflt)); case K_NOT: return !eval_boolean_expression(cadr(expr), fn, dflt); default: return (*fn)(expr); } } else { return (*fn)(expr); } } int eval_number(Obj *val, int *isnumber) { /* (should have a non-complaining eval for this) */ if (numberp(val)) { *isnumber = TRUE; return c_number(val); } else if (symbolp(val) && boundp(val) && numberp(symbol_value(val))) { *isnumber = TRUE; return c_number(symbol_value(val)); } else { *isnumber = FALSE; return 0; } } /* Choose from a list of weights and values, which can be formatted as a flat list of (n1 v1 n2 v2 ...), or as ((n1 v1) (n2 v2) ...) */ Obj * choose_from_weighted_list(Obj *lis, int *totalweightp, int flat) { int n, sofar, weight; char buf[BUFSIZE]; Obj *rest, *head, *tail, *rslt; if (*totalweightp <= 0) { for_all_list(lis, rest) { if (flat) { if (numberp(car(rest))) { weight = c_number(car(rest)); rest = cdr(rest); } else { weight = 1; } } else { head = car(rest); weight = ((consp(head) && numberp(car(head))) ? c_number(car(head)) : 1); } *totalweightp += weight; } } /* Warn about dubious weights - note that we can continue to execute, xrandom on 0 is still 0. */ if (*totalweightp == 0) { sprintlisp(buf, lis, BUFSIZE); run_warning("Sum of weights in weighted list `%s' is 0", buf); } n = xrandom(*totalweightp); sofar = 0; rslt = lispnil; for_all_list(lis, rest) { if (flat) { if (numberp(car(rest))) { sofar += c_number(car(rest)); rest = cdr(rest); } else { sofar += 1; } tail = car(rest); } else { head = car(rest); if (consp(head) && numberp(car(head))) { sofar += c_number(car(head)); tail = cdr(head); } else { sofar += 1; tail = head; } } if (sofar > n) { rslt = tail; break; } } return rslt; } int interpolate_in_list(int val, Obj *lis, int *rslt) { int first, thisin, thisval, nextin, nextval; Obj *rest, *head, *next; first = TRUE; for_all_list(lis, rest) { head = car(rest); thisin = c_number(car(head)); thisval = c_number(cadr(head)); if (cdr(rest) != lispnil) { next = cadr(rest); nextin = c_number(car(next)); nextval = c_number(cadr(next)); first = FALSE; } else if (first) { if (val == thisin) { *rslt = thisval; return 0; } else if (val < thisin) { return (-1); } else { return 1; } } else { /* We're at the end of a several-item list; the value must be too high. */ return 1; } if (val < thisin) { return (-1); } else if (between(thisin, val, nextin)) { if (val == thisin) { *rslt = thisval; } else if (val == nextin) { *rslt = nextval; } else { *rslt = thisval; if (val != thisin && nextin != thisin) { /* Add the linear interpolation. */ *rslt += ((nextval - thisval) * (val - thisin)) / (nextin - thisin); } } return 0; } } return (-1); } int interpolate_in_list_ext(int val, Obj *lis, int mindo, int minval, int minrslt, int maxdo, int maxval, int maxrslt, int *rslt) { int first, thisin, thisval, nextin, nextval; Obj *rest, *head, *next; /* (should use the additional parameters) */ first = TRUE; for_all_list(lis, rest) { head = car(rest); thisin = c_number(car(head)); thisval = c_number(cadr(head)); if (cdr(rest) != lispnil) { next = cadr(rest); nextin = c_number(car(next)); nextval = c_number(cadr(next)); first = FALSE; } else if (first) { if (val == thisin) { *rslt = thisval; return 0; } else if (val < thisin) { return (-1); } else { return 1; } } else { /* We're at the end of a several-item list; the value must be too high. */ return 1; } if (val < thisin) { return (-1); } else if (between(thisin, val, nextin)) { if (val == thisin) { *rslt = thisval; } else if (val == nextin) { *rslt = nextval; } else { *rslt = thisval; if (val != thisin && nextin != thisin) { /* Add the linear interpolation. */ *rslt += ((nextval - thisval) * (val - thisin)) / (nextin - thisin); } } return 0; } } return (-1); } void interp_short_array(short *arr, Obj *lis, int n) { int i = 0; Obj *rest, *head; /* Assume that if the destination array does not exist, there is probably a reason, and it's not our concern. */ if (arr == NULL) return; for_all_list(lis, rest) { head = car(rest); if (numberp(head)) { if (i < n) { arr[i++] = c_number(head); } else { init_warning("too many numbers in list"); break; } } } } void interp_long_array(long *arr, Obj *lis, int n) { int i = 0; Obj *rest, *head; /* Assume that if the destination array does not exist, there is probably a reason, and it's not our concern. */ if (arr == NULL) return; for_all_list(lis, rest) { head = car(rest); if (numberp(head)) { if (i < n) { arr[i++] = c_number(head); } else { init_warning("too many numbers in list"); break; } } } }