Logo Search packages:      
Sourcecode: xconq version File versions  Download package

lisp.c

/* 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, " <unbound>");
      }
    }
    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;
          }
      }
    }
}

Generated by  Doxygen 1.6.0   Back to index