home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Games / Xconq 7.1.0 / src / xconq-7.1.0 / kernel / lisp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-07  |  27.2 KB  |  1,410 lines  |  [TEXT/R*ch]
  1. /* Support for Lisp-style data.
  2.    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Stanley T. Shebs.
  3.  
  4. Xconq is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2, or (at your option)
  7. any later version.  See the file COPYING.  */
  8.  
  9. /* (should have some deallocation support, since some game init data
  10.    can be discarded) */
  11.  
  12. #include "config.h"
  13. #include "misc.h"
  14. #include "lisp.h"
  15.  
  16. static Symentry *lookup_string PARAMS ((char *str));
  17. static int hash_name PARAMS ((char *str));
  18.  
  19. /* Pointer to "nil", the empty list. */
  20.  
  21. Obj *lispnil;
  22.  
  23. /* Pointer to "eof", which is returned if no more forms in a file. */
  24.  
  25. Obj *lispeof;
  26.  
  27. /* Pointer to a "closing paren" object used only during list reading. */
  28.  
  29. Obj *lispclosingparen;
  30.  
  31. /* Pointer to an "unbound" object that indicates unbound variables. */
  32.  
  33. Obj *lispunbound;
  34.  
  35. /* Current number of symbols in the symbol table. */
  36.  
  37. int numsymbols = 0;
  38.  
  39. /* Pointer to the base of the symbol table itself. */
  40.  
  41. static Symentry **symboltablebase = NULL;
  42.  
  43. /* The number of Lisp objects allocated so far. */
  44.  
  45. int lispmalloc = 0;
  46.  
  47. /* This variable is used to track the depth of nested #| |# comments. */
  48.  
  49. int commentdepth = 0;
  50.  
  51. int actually_read_lisp = TRUE;
  52.  
  53. #define BIGBUF 1000
  54.  
  55. static char *lispstrbuf = NULL;
  56.  
  57. static int *startlineno;
  58. static int *endlineno;
  59. static char linenobuf[50];
  60.  
  61. /* Allocate a new Lisp object, count it as such. */
  62.  
  63. static Obj *
  64. newobj()
  65. {
  66.     lispmalloc += sizeof(Obj);
  67.     return ((Obj *) xmalloc(sizeof(Obj)));
  68. }
  69.  
  70. /* Pre-create some objects that should always exist. */
  71.  
  72. void
  73. init_lisp()
  74. {
  75.     /* Allocate Lisp's NIL. */
  76.     lispnil = newobj();
  77.     lispnil->type = NIL;
  78.     /* Do this so car/cdr of nil is nil, might cause infinite loops though. */
  79.     lispnil->v.cons.car = lispnil;
  80.     lispnil->v.cons.cdr = lispnil;
  81.     /* We use the eof object to recognize eof when reading a file. */
  82.     lispeof = newobj();
  83.     lispeof->type = EOFOBJ;
  84.     /* The "closing paren" object just flags closing parens while reading. */
  85.     lispclosingparen = newobj();
  86.     /* The "unbound" object is for unbound variables. */
  87.     lispunbound = newobj();
  88.     /* Set up the symbol table. */
  89.     symboltablebase = (Symentry **) xmalloc(256 * sizeof(Symentry *));
  90.     numsymbols = 0;
  91.     init_predefined_symbols();
  92. }
  93.  
  94. /* Ultra-simple "streams" that can be stdio FILEs or strings. */
  95.  
  96. int
  97. strmgetc(strm)
  98. Strm *strm;
  99. {
  100.     if (strm->type == stringstrm) {
  101.     if (*(strm->ptr.sp) == '\0')
  102.       return EOF;
  103.     return *((strm->ptr.sp)++);
  104.     } else {
  105.     return getc(strm->ptr.fp);
  106.     }
  107. }
  108.  
  109. void
  110. strmungetc(ch, strm)
  111. int ch;
  112. Strm *strm;
  113. {
  114.     if (strm->type == stringstrm) {
  115.     --strm->ptr.sp;
  116.     } else {
  117.     ungetc(ch, strm->ptr.fp);
  118.     }
  119. }
  120.  
  121. /* El cheapo Lisp reader.  Lisp objects are generally advertised by their
  122.    first characters, but lots of semantics actions happen while reading, so
  123.    this isn't really a regular expression reader. */
  124.  
  125. Obj *
  126. read_form(fp, p1, p2)
  127. FILE *fp;
  128. int *p1, *p2;
  129. {
  130.     Obj *rslt;
  131.     Strm tmpstrm;
  132.  
  133.     commentdepth = 0;
  134.     startlineno = p1;
  135.     endlineno = p2;
  136.     tmpstrm.type = filestrm;
  137.     tmpstrm.ptr.fp = fp;
  138.     rslt = read_form_aux(&tmpstrm);
  139.     if (rslt == lispclosingparen) {
  140.     sprintf_context(linenobuf, 50, startlineno, endlineno, NULL);
  141.     init_warning("extra close paren, substituting nil%s", linenobuf);
  142.     rslt = lispnil;
  143.     }
  144.     return rslt;
  145. }
  146.  
  147. Obj *
  148. read_form_from_string(str, p1, p2)
  149. char *str;
  150. int *p1, *p2;
  151. {
  152.     Obj *rslt;
  153.     Strm tmpstrm;
  154.  
  155.     commentdepth = 0;
  156.     startlineno = p1;
  157.     endlineno = p2;
  158.     tmpstrm.type = stringstrm;
  159.     tmpstrm.ptr.sp = str;
  160.     rslt = read_form_aux(&tmpstrm);
  161.     if (rslt == lispclosingparen) {
  162.     sprintf_context(linenobuf, 50, startlineno, endlineno, NULL);
  163.     init_warning("extra close paren, substituting nil%s", linenobuf);
  164.     rslt = lispnil;
  165.     }
  166.     return rslt;
  167. }
  168.  
  169. void
  170. sprintf_context(buf, n, start, end, context)
  171. char *buf, *context;
  172. int n, *start, *end;
  173. {
  174.     buf[0] = '\0';
  175.     if (start != NULL && end != NULL) {
  176.     if (*start == *end) {
  177.         sprintf(buf, " (at line %d)", *start);
  178.     } else {
  179.         sprintf(buf, " (lines %d to %d)", *start, *end);
  180.     }
  181.     }
  182.     if (!empty_string(context)) {
  183.     strncpy(buf+strlen(buf), context, n - 1);
  184.     buf[n - 1] = '\0';
  185.     }
  186. }
  187.  
  188. Obj *
  189. read_form_aux(strm)
  190. Strm *strm;
  191. {
  192.     int minus, factor, commentclosed, ch, ch2, ch3, ch4, num;
  193.  
  194.     while ((ch = strmgetc(strm)) != EOF) {
  195.     /* Recognize nested comments specially. */
  196.     if (ch == '#') {
  197.         if ((ch2 = strmgetc(strm)) == '|') {
  198.         commentclosed = FALSE;
  199.         ++commentdepth;
  200.         while ((ch3 = strmgetc(strm)) != EOF) {
  201.             if (ch3 == '|') {
  202.             /* try to recognize # */
  203.             if ((ch4 = strmgetc(strm)) == '#') {
  204.                 --commentdepth;
  205.                 if (commentdepth == 0) {
  206.                 commentclosed = TRUE;
  207.                 break;
  208.                 }
  209.             } else {
  210.                 strmungetc(ch4, strm);
  211.             }
  212.             } else if (ch3 == '#') {
  213.             if ((ch4 = strmgetc(strm)) == '|') {
  214.                 ++commentdepth;
  215.             } else {
  216.                 strmungetc(ch4, strm);
  217.             }
  218.             } else if (ch3 == '\n') {
  219.             if (endlineno != NULL)
  220.               ++(*endlineno);
  221.             announce_read_progress();
  222.             }
  223.         }
  224.         if (!commentclosed) {
  225.             init_warning("comment not closed at eof");
  226.         }
  227.         /* Always pick up the next char. */
  228.         ch = strmgetc(strm);
  229.         } else {
  230.         strmungetc(ch2, strm);
  231.             return intern_symbol("#");
  232.         }
  233.     }
  234.     /* Regular lexical recognition. */
  235.     if (isspace(ch)) {
  236.         /* Nothing to do here except count lines. */
  237.         if (ch == '\n') {
  238.         if (endlineno != NULL)
  239.           ++(*endlineno);
  240.         if (startlineno != NULL)
  241.           ++(*startlineno);
  242.         announce_read_progress();
  243.         }
  244.     } else if (ch == ';') {
  245.         /* Discard all from here to the end of this line. */
  246.         while ((ch = strmgetc(strm)) != EOF && ch != '\n');
  247.         if (endlineno != NULL)
  248.           ++(*endlineno);
  249.         announce_read_progress();
  250.     } else if (ch == '(') {
  251.         /* Jump into a list-reading mode. */
  252.         return read_list(strm);
  253.     } else if (ch == ')') {
  254.         /* This is just to flag the end of the list for read_list. */
  255.         return lispclosingparen;
  256.     } else if (ch == '"') {
  257.         read_delimited_text(strm, "\"", FALSE, FALSE);
  258.         if (!actually_read_lisp)
  259.           return lispnil;
  260.         return new_string(copy_string(lispstrbuf));
  261.     } else if (ch == '|') {
  262.         read_delimited_text(strm, "|", FALSE, FALSE);
  263.         if (!actually_read_lisp)
  264.           return lispnil;
  265.         return intern_symbol(lispstrbuf);
  266.     } else if (strchr("`'", ch)) {
  267.         if (!actually_read_lisp)
  268.           return lispnil;
  269.         return cons(intern_symbol("quote"),
  270.             cons(read_form_aux(strm), lispnil));
  271.     } else if (isdigit(ch) || ch == '-' || ch == '+' || ch == '.') {
  272.         int numdice = 0, dice = 0, indice = FALSE;
  273.  
  274.         minus = (ch == '-');
  275.         factor = (ch == '.' ? 100 : 1);
  276.         num = (minus ? 0 : ch - '0');
  277.         while ((ch = strmgetc(strm)) != EOF) {
  278.             if (isdigit(ch)) {
  279.                 /* should ignore decimal digits past second one */
  280.             num = num * 10 + ch - '0';
  281.             if (factor > 1)
  282.               factor /= 10;
  283.         } else if (ch == 'd') {
  284.             numdice = num;
  285.             num = 0;
  286.             indice = TRUE;
  287.         } else if (ch == '+' || ch == '-') {
  288.             dice = num;
  289.             num = 0;
  290.             indice = FALSE;
  291.         } else if (ch == '.') {
  292.             factor = 100;
  293.         } else {
  294.             break;
  295.         }
  296.         }
  297.         /* If number was followed by a % char, discard the char, otherwise
  298.            put it back on the stream. */
  299.         if (ch != '%')
  300.           strmungetc(ch, strm);
  301.         if (indice) {
  302.         dice = num;
  303.         num = 0;
  304.         }
  305.         if (minus)
  306.           num = 0 - num;
  307.         if (numdice > 0) {
  308.             num = (1 << 14) | (numdice << 11) | (dice << 7) | (num & 0x7f);
  309.         } else {
  310.             num = factor * num;
  311.         }
  312.         if (!actually_read_lisp)
  313.           return lispnil;
  314.         return new_number(num);
  315.     } else {
  316.         /* Read a regular symbol. */
  317.         /* The char we just looked will be the first char. */
  318.         strmungetc(ch, strm);
  319.         /* Now read until any special char seen. */
  320.         ch = read_delimited_text(strm, "();\"'`#", TRUE, TRUE);
  321.         /* Undo the extra char we read in order to detect the end
  322.            of the symbol. */
  323.         strmungetc(ch, strm);
  324.         /* Need to recognize nil specially here. */
  325.         if (strcmp("nil", lispstrbuf) == 0) {
  326.         return lispnil;
  327.         } else if (!actually_read_lisp) {
  328.             if (strcmp("else", lispstrbuf) == 0)
  329.           return intern_symbol(lispstrbuf);
  330.             if (strcmp("end-if", lispstrbuf) == 0)
  331.           return intern_symbol(lispstrbuf);
  332.         return lispnil;    
  333.         } else {
  334.         return intern_symbol(lispstrbuf);
  335.         }
  336.     }
  337.     }
  338.     return lispeof;
  339. }
  340.  
  341. /* Read a sequence of expressions terminated by a closing paren.  This works
  342.    by looping; although recursion is more elegant, if the compiler does not
  343.    turn tail-recursion into loops, long lists can blow the stack.  (This has
  344.    happened with real saved games.) */
  345.  
  346. Obj *
  347. read_list(strm)
  348. Strm *strm;
  349. {
  350.     Obj *thecar, *thenext, *lis, *endlis;
  351.  
  352.     thecar = read_form_aux(strm);
  353.     if (thecar == lispclosingparen) {
  354.     return lispnil;
  355.     } else if (thecar == lispeof) {
  356.     goto at_eof;
  357.     } else {
  358.     lis = cons(thecar, lispnil);
  359.     endlis = lis;
  360.     while (TRUE) {
  361.         thenext = read_form_aux(strm);
  362.         if (thenext == lispclosingparen) {
  363.         break;
  364.         } else if (thenext == lispeof) {
  365.         goto at_eof;
  366.         } else {
  367.         set_cdr(endlis, cons(thenext, lispnil));
  368.         endlis = cdr(endlis);
  369.         }
  370.     }
  371.     return lis;
  372.     }
  373.   at_eof:
  374.     sprintf_context(linenobuf, 50, startlineno, endlineno, NULL);
  375.     init_warning("missing a close paren, returning EOF%s", linenobuf);
  376.     return lispeof;
  377. }
  378.  
  379. /* Read a quantity of text delimited by a char from the given string,
  380.    possibly also by whitespace or EOF. */
  381.  
  382. int
  383. read_delimited_text(strm, delim, spacedelimits, eofdelimits)
  384. Strm *strm;
  385. char *delim;
  386. int spacedelimits, eofdelimits;
  387. {
  388.     int ch, octch, j = 0, warned = FALSE;
  389.  
  390.     if (lispstrbuf == NULL)
  391.       lispstrbuf = (char *) xmalloc(BIGBUF);
  392.     while ((ch = strmgetc(strm)) != EOF
  393.        && (!spacedelimits || !isspace(ch))
  394.        && !strchr(delim, ch)) {
  395.     /* Handle escape char by replacing with next char,
  396.        or maybe interpret an octal sequence. */
  397.     if (ch == '\\') {
  398.         ch = strmgetc(strm);
  399.         /* Octal chars introduced by a leading zero. */
  400.         if (ch == '0') {
  401.         octch = 0;
  402.         /* Soak up numeric digits (don't complain about 8 or 9,
  403.            sloppy but traditional). */
  404.         while ((ch = strmgetc(strm)) != EOF && isdigit(ch)) {
  405.             octch = 8 * octch + ch - '0';
  406.         }
  407.         /* The non-digit char is actually next one in the string. */
  408.         strmungetc(ch, strm);
  409.         ch = octch;
  410.         }
  411.     }
  412.     if (j >= BIGBUF) {
  413.         /* Warn about buffer overflow, but only once per string,
  414.            then still read chars but discard them. */
  415.         if (!warned) {
  416.         init_warning(
  417.          "exceeded max sym/str length (%d chars), ignoring rest",
  418.                  BIGBUF);
  419.         warned = TRUE;
  420.         }
  421.     } else {
  422.         lispstrbuf[j++] = ch;
  423.     }
  424.     }
  425.     lispstrbuf[j] = '\0';
  426.     return ch;
  427. }
  428.  
  429. /* The usual list length function. */
  430.  
  431. int
  432. length(list)
  433. Obj *list;
  434. {
  435.     int rslt = 0;
  436.  
  437.     while (list != lispnil) {
  438.     list = cdr(list);
  439.     ++rslt;
  440.     }
  441.     return rslt;
  442. }
  443.  
  444.  
  445. /* Basic allocation routines. */
  446.  
  447. Obj *
  448. new_string(str)
  449. char *str;
  450. {
  451.     Obj *new = newobj();
  452.  
  453.     new->type = STRING;
  454.     new->v.str = str;
  455.     return new;
  456. }
  457.  
  458. Obj *
  459. new_number(num)
  460. int num;
  461. {
  462.     Obj *new = newobj();
  463.  
  464.     new->type = NUMBER;
  465.     new->v.num = num;
  466.     return new;
  467. }
  468.  
  469. Obj *
  470. new_utype(u)
  471. int u;
  472. {
  473.     Obj *new = newobj();
  474.  
  475.     new->type = UTYPE;
  476.     new->v.num = u;
  477.     return new;
  478. }
  479.  
  480. Obj *
  481. new_mtype(r)
  482. int r;
  483. {
  484.     Obj *new = newobj();
  485.  
  486.     new->type = MTYPE;
  487.     new->v.num = r;
  488.     return new;
  489. }
  490.  
  491. Obj *
  492. new_ttype(t)
  493. int t;
  494. {
  495.     Obj *new = newobj();
  496.  
  497.     new->type = TTYPE;
  498.     new->v.num = t;
  499.     return new;
  500. }
  501.  
  502. Obj *
  503. new_pointer(sym, ptr)
  504. Obj *sym;
  505. char *ptr;
  506. {
  507.     Obj *new = newobj();
  508.  
  509.     new->type = POINTER;
  510.     new->v.ptr.sym = sym;
  511.     new->v.ptr.data = ptr;
  512.     return new;
  513. }
  514.  
  515. Obj *
  516. cons(x, y)
  517. Obj *x, *y;
  518. {
  519.     Obj *new = newobj();
  520.  
  521.     new->type = CONS;  
  522.     new->v.cons.car = x;  new->v.cons.cdr = y;
  523.     if (!listp(y))
  524.       run_warning("cdr of cons is not a list");
  525.     return new;
  526. }
  527.  
  528. void
  529. type_warning(funname, x, typename, subst)
  530. char *funname, *typename;
  531. Obj *x, *subst;
  532. {
  533.     char buf1[BUFSIZE], buf2[BUFSIZE];
  534.  
  535.     sprintlisp(buf1, x);
  536.     sprintlisp(buf2, subst);
  537.     run_warning("%s of non-%s `%s' being taken, returning `%s' instead",
  538.                 funname, typename, buf1, buf2);
  539. }
  540.  
  541. /* The usual suspects. */
  542.  
  543. Obj *
  544. car(x)
  545. Obj *x;
  546. {
  547.     if (x->type == CONS || x->type == NIL) {
  548.     return x->v.cons.car;
  549.     } else {
  550.         type_warning("Car", x, "list", lispnil);
  551.     return lispnil;
  552.     }
  553. }
  554.  
  555. Obj *
  556. cdr(x)
  557. Obj *x;
  558. {
  559.     if (x->type == CONS || x->type == NIL) {
  560.     return x->v.cons.cdr;
  561.     } else {
  562.         type_warning("Cdr", x, "list", lispnil);
  563.     return lispnil;
  564.     }
  565. }
  566.  
  567. Obj *
  568. cadr(x)
  569. Obj *x;
  570. {
  571.     return car(cdr(x));
  572. }
  573.  
  574. Obj *
  575. cddr(x)
  576. Obj *x;
  577. {
  578.     return cdr(cdr(x));
  579. }
  580.  
  581. Obj *
  582. caddr(x)
  583. Obj *x;
  584. {
  585.     return car(cdr(cdr(x)));
  586. }
  587.  
  588. void
  589. set_cdr(x, v)
  590. Obj *x, *v;
  591. {
  592.     if (x->type == CONS) {
  593.     x->v.cons.cdr = v;
  594.     } else {
  595.         type_warning("set_cdr", x, "cons", lispnil);
  596.     }
  597. }
  598.  
  599. /* Return the string out of both strings and symbols. */
  600.  
  601. char *
  602. c_string(x)
  603. Obj *x;
  604. {
  605.     if (x->type == STRING) {
  606.     return x->v.str;
  607.     } else if (x->type == SYMBOL) {
  608.     return x->v.sym.symentry->name;
  609.     } else {
  610.          type_warning("c_string", x, "string/symbol", lispnil);
  611.     return "";
  612.    }
  613. }
  614.  
  615. /* Return the actual number in a number object. */
  616.  
  617. int
  618. c_number(x)
  619. Obj *x;
  620. {
  621.     if (x->type == NUMBER
  622.     || x->type == UTYPE
  623.     || x->type == MTYPE
  624.     || x->type == TTYPE) {
  625.     return x->v.num;
  626.     } else {
  627.          type_warning("c_number", x, "number", lispnil);
  628.     return 0;
  629.     }
  630. }
  631.  
  632. Obj *
  633. intern_symbol(str)
  634. char *str;
  635. {
  636.     int n;
  637.     Symentry *se;
  638.     Obj *new1;
  639.  
  640.     se = lookup_string(str);
  641.     if (se) {
  642.     return se->symbol;
  643.     } else {
  644.     new1 = newobj();
  645.     new1->type = SYMBOL;
  646.     se = (Symentry *) xmalloc(sizeof(Symentry));
  647.     new1->v.sym.symentry = se;
  648.     /* Declare a newly created symbol to be unbound. */
  649.     new1->v.sym.value = lispunbound;
  650.     se->name = copy_string(str); 
  651.     se->symbol = new1;
  652.     se->constantp = FALSE;
  653.     n = hash_name(str);
  654.     /* Push the symbol entry onto the front of its hash bucket. */
  655.     se->next = symboltablebase[n];
  656.     symboltablebase[n] = se;
  657.     ++numsymbols;
  658.     return new1;
  659.     }
  660. }
  661.  
  662. /* Given a string, try to find a symbol entry with that as its name. */
  663.  
  664. static Symentry *
  665. lookup_string(str)
  666. char *str;
  667. {
  668.     Symentry *se;
  669.  
  670.     for (se = symboltablebase[hash_name(str)]; se != NULL; se = se->next) {
  671.     if (strcmp(se->name, str) == 0)
  672.       return se;
  673.     }
  674.     return NULL;
  675. }
  676.  
  677. static int
  678. hash_name(str)
  679. char *str;
  680. {
  681.     return str[0];
  682. }
  683.  
  684. Obj *
  685. symbol_value(sym)
  686. Obj *sym;
  687. {
  688.     Obj *val = sym->v.sym.value;
  689.  
  690.     if (val == lispunbound) {
  691.     run_warning("unbound symbol `%s', substituting nil", c_string(sym));
  692.     val = lispnil;
  693.     }
  694.     return val;
  695. }
  696.  
  697. Obj *
  698. setq(sym, x)
  699. Obj *sym, *x;
  700. {
  701.     if (!symbolp(sym)) {
  702.     run_warning("Can't set a non-symbol, ignoring attempt");
  703.     return x;
  704.     }
  705.     if (constantp(sym)) {
  706.         run_warning("Can't alter the constant `%s', ignoring attempt",
  707.             c_string(sym));
  708.         return x;
  709.     }
  710.     sym->v.sym.value = x;
  711.     return x;
  712. }
  713.  
  714. void
  715. makunbound(sym)
  716. Obj *sym;
  717. {
  718.     sym->v.sym.value = lispunbound;
  719. }
  720.  
  721. void
  722. flag_as_constant(sym)
  723. Obj *sym;
  724. {
  725.     sym->v.sym.symentry->constantp = TRUE;
  726. }
  727.  
  728. int
  729. constantp(sym)
  730. Obj *sym;
  731. {    
  732.     return (sym->v.sym.symentry->constantp);
  733. }
  734.  
  735. int
  736. numberp(x)
  737. Obj *x;
  738. {
  739.     return (x->type == NUMBER);
  740. }
  741.  
  742. int
  743. stringp(x)
  744. Obj *x;
  745. {
  746.     return (x->type == STRING);
  747. }
  748.  
  749. int
  750. symbolp(x)
  751. Obj *x;
  752. {
  753.     return (x->type == SYMBOL);
  754. }
  755.  
  756. int
  757. consp(x)
  758. Obj *x;
  759. {
  760.     return (x->type == CONS);
  761. }
  762.  
  763. int
  764. utypep(x)
  765. Obj *x;
  766. {
  767.     return (x->type == UTYPE);
  768. }
  769.  
  770. int
  771. mtypep(x)
  772. Obj *x;
  773. {
  774.     return (x->type == MTYPE);
  775. }
  776.  
  777. int
  778. ttypep(x)
  779. Obj *x;
  780. {
  781.     return (x->type == TTYPE);
  782. }
  783.  
  784. int
  785. pointerp(x)
  786. Obj *x;
  787. {
  788.     return (x->type == POINTER);
  789. }
  790.  
  791. int
  792. boundp(sym)
  793. Obj *sym;
  794. {
  795.     return (sym->v.sym.value != lispunbound);
  796. }
  797.  
  798. int
  799. numberishp(x)
  800. Obj *x;
  801. {
  802.     return (x->type == NUMBER
  803.         || x->type == UTYPE
  804.         || x->type == MTYPE
  805.         || x->type == TTYPE);
  806. }
  807.  
  808. int
  809. listp(x)
  810. Obj *x;
  811. {
  812.     return (x->type == NIL || x->type == CONS);
  813. }
  814.  
  815. /* General structural equality test.  Assumes that it is not getting
  816.    passed any circular structures. */
  817.  
  818. int
  819. equal(x, y)
  820. Obj *x, *y;
  821. {
  822.     /* Objects of different types can never be equal. */
  823.     if (x->type != y->type)
  824.       return FALSE;
  825.     /* Identical objects are always equal. */
  826.     if (x == y)
  827.       return TRUE;
  828.     switch (x->type) {
  829.       case NUMBER:
  830.       case UTYPE:
  831.       case MTYPE:
  832.       case TTYPE:
  833.     return (c_number(x) == c_number(y));
  834.       case STRING:
  835.     return (strcmp(c_string(x), c_string(y)) == 0);
  836.       case SYMBOL:
  837.     return (strcmp(c_string(x), c_string(y)) == 0);
  838.       case CONS:
  839.     return (equal(car(x), car(y)) && equal(cdr(x), cdr(y)));
  840.       case POINTER:
  841.     return FALSE;
  842.       default:
  843.     case_panic("lisp type", x->type);
  844.     return FALSE;
  845.     }
  846. }
  847.  
  848. int
  849. member(x, lis)
  850. Obj *x, *lis;
  851. {
  852.     if (lis == lispnil) {
  853.     return FALSE;
  854.     } else if (!consp(lis)) {
  855.     /* should probably be an error of some sort */
  856.     return FALSE;
  857.     } else if (equal(x, car(lis))) {
  858.     return TRUE;
  859.     } else {
  860.     return member(x, cdr(lis));
  861.     }
  862. }
  863.  
  864. /* Return the nth element of a list. */
  865.  
  866. Obj *
  867. elt(lis, n)
  868. Obj *lis;
  869. int n;
  870. {
  871.     while (n-- > 0) {
  872.     lis = cdr(lis);
  873.     }
  874.     return car(lis);
  875. }
  876.  
  877. Obj *
  878. reverse(lis)
  879. Obj *lis;
  880. {
  881.     Obj *rslt = lispnil;
  882.  
  883.     for (; lis != lispnil; lis = cdr(lis)) {
  884.     rslt = cons(car(lis), rslt);
  885.     }
  886.     return rslt;
  887. }
  888.  
  889. Obj *
  890. find_at_key(lis, key)
  891. Obj *lis;
  892. char *key;
  893. {
  894.     Obj *rest, *bdgs, *bdg;
  895.  
  896.     for_all_list(lis, rest) {
  897.     bdgs = car(rest);
  898.     bdg = car(bdgs);
  899.     if (stringp(bdg) && strcmp(key, c_string(bdg)) == 0) {
  900.         return cdr(bdgs);
  901.     }
  902.     }
  903.     return lispnil;
  904. }
  905.  
  906. Obj *
  907. replace_at_key(lis, key, newval)
  908. Obj *lis, *newval;
  909. char *key;
  910. {
  911.     Obj *rest, *bdgs, *bdg;
  912.  
  913.     for_all_list(lis, rest) {
  914.     bdgs = car(rest);
  915.     bdg = car(bdgs);
  916.     if (stringp(bdg) && strcmp(key, c_string(bdg)) == 0) {
  917.         set_cdr(bdgs, newval);
  918.         return lis;
  919.     }
  920.     }
  921.     return cons(cons(new_string(key), newval), lis);
  922. }
  923.  
  924. void
  925. fprintlisp(fp, obj)
  926. FILE *fp;
  927. Obj *obj;
  928. {
  929.     int needescape;
  930.     char *str, *tmp;
  931.  
  932.     /* Doublecheck, just in case caller is not so careful. */
  933.     if (obj == NULL) {
  934.     run_warning("Trying to print NULL as object, skipping");
  935.     return;
  936.     }
  937.     switch (obj->type) {
  938.       case NIL:
  939.     fprintf(fp, "nil");
  940.     break;
  941.       case NUMBER:
  942.     fprintf(fp, "%d", obj->v.num);
  943.     break;
  944.       case STRING:
  945.     if (strchr(obj->v.str, '"')) {
  946.         fprintf(fp, "\"");
  947.         for (tmp = obj->v.str; *tmp != '\0'; ++tmp) {
  948.         if (*tmp == '"')
  949.           fprintf(fp, "\\");
  950.         fprintf(fp, "%c", *tmp);
  951.         }
  952.         fprintf(fp, "\"");
  953.     } else {
  954.         /* Just printf the whole string. */
  955.         fprintf(fp, "\"%s\"", obj->v.str);
  956.     }
  957.     break;
  958.       case SYMBOL:
  959.     needescape = FALSE;
  960.     str = c_string(obj);
  961.     if (isdigit(str[0])) {
  962.         needescape = TRUE;
  963.     } else {
  964.         /* Scan the symbol's name looking for special chars. */
  965.         for (tmp = str; *tmp != '\0'; ++tmp) {
  966.         if (strchr(" ()#\";|", *tmp)) {
  967.             needescape = TRUE;
  968.             break;
  969.         }
  970.         }
  971.     }
  972.     if (needescape) {
  973.         fprintf(fp, "|%s|", str);
  974.     } else {
  975.         fprintf(fp, "%s", str);
  976.     }
  977.     break;
  978.       case CONS:
  979.     fprintf(fp, "(");
  980.     fprintlisp(fp, car(obj));
  981.     /* Note that there are no dotted pairs in our version of Lisp. */
  982.     fprint_list(fp, cdr(obj));
  983.     break;
  984.       case UTYPE:
  985.     fprintf(fp, "u#%d", obj->v.num);
  986.     break;
  987.       case MTYPE:
  988.     fprintf(fp, "m#%d", obj->v.num);
  989.     break;
  990.       case TTYPE:
  991.     fprintf(fp, "t#%d", obj->v.num);
  992.     break;
  993.       case POINTER:
  994.     fprintlisp(fp, obj->v.ptr.sym);
  995.     fprintf(fp, " #|0x%lx|#", (long) obj->v.ptr.data);
  996.     break;
  997.       default:
  998.     case_panic("lisp type", obj->type);
  999.     break;
  1000.     }
  1001. }
  1002.  
  1003. void
  1004. fprint_list(fp, obj)
  1005. FILE *fp;
  1006. Obj *obj;
  1007. {
  1008.     Obj *tmp;
  1009.  
  1010.     for_all_list(obj, tmp) {
  1011.     fprintf(fp, " ");
  1012.     fprintlisp(fp, car(tmp));
  1013.     }    
  1014.     fprintf(fp, ")");
  1015. }
  1016.  
  1017. void
  1018. sprintlisp(buf, obj)
  1019. char *buf;
  1020. Obj *obj;
  1021. {
  1022.     if (strlen(buf) + 20 > BUFSIZE)
  1023.       return;
  1024.     switch (obj->type) {
  1025.       case NIL:
  1026.     sprintf(buf, "nil");
  1027.     break;
  1028.       case NUMBER:
  1029.     sprintf(buf, "%d", obj->v.num);
  1030.     break;
  1031.       case STRING:
  1032.     /* (should print escape chars if needed) */
  1033.     sprintf(buf, "\"%s\"", obj->v.str);
  1034.     break;
  1035.       case SYMBOL:
  1036.     /* (should print escape chars if needed) */
  1037.     sprintf(buf, "%s", c_string(obj));
  1038.     break;
  1039.       case CONS:
  1040.     strcpy(buf, "(");
  1041.     sprintlisp(buf+strlen(buf), car(obj));
  1042.     /* No dotted pairs allowed in our version of Lisp. */
  1043.     sprint_list(buf+strlen(buf), cdr(obj));
  1044.     break;
  1045.       case UTYPE:
  1046.     sprintf(buf, "u#%d", obj->v.num);
  1047.     break;
  1048.       case MTYPE:
  1049.     sprintf(buf, "m#%d", obj->v.num);
  1050.     break;
  1051.       case TTYPE:
  1052.     sprintf(buf, "t#%d", obj->v.num);
  1053.     break;
  1054.       case POINTER:
  1055.     sprintlisp(buf, obj->v.ptr.sym);
  1056.     sprintf(buf+strlen(buf), " #|0x%lx|#", (long) obj->v.ptr.data);
  1057.     break;
  1058.       default:
  1059.     case_panic("lisp type", obj->type);
  1060.     break;
  1061.     }
  1062. }
  1063.  
  1064. void
  1065. sprint_list(buf, obj)
  1066. char *buf;
  1067. Obj *obj;
  1068. {
  1069.     Obj *tmp;
  1070.  
  1071.     buf[0] = '\0';
  1072.     for (tmp = obj; tmp != lispnil; tmp = cdr(tmp)) {
  1073.     if (strlen(buf) + 10 > BUFSIZE)
  1074.       return;
  1075.     strcat(buf, " ");
  1076.     sprintlisp(buf+strlen(buf), car(tmp));
  1077.     }    
  1078.     strcat(buf, ")");
  1079. }
  1080.  
  1081. #ifdef DEBUGGING
  1082. /* For calling from debuggers, at least that those that support output to stderr. */
  1083.  
  1084. void
  1085. dlisp(x)
  1086. Obj *x;
  1087. {
  1088.     fprintlisp(stderr, x);
  1089.     fprintf(stderr, "\n");
  1090. }
  1091. #endif /* DEBUGGING */
  1092.  
  1093. void
  1094. print_form_and_value(fp, form)
  1095. FILE *fp;
  1096. Obj *form;
  1097. {
  1098.     fprintlisp(fp, form);
  1099.     if (symbolp(form)) {
  1100.     if (boundp(form)) {
  1101.         fprintf(fp, " -> ");
  1102.         fprintlisp(fp, symbol_value(form));
  1103.     } else {
  1104.         fprintf(fp, " <unbound>");
  1105.     }
  1106.     }
  1107.     fprintf(fp, "\n");
  1108. }
  1109.  
  1110. Obj *
  1111. append_two_lists(x1, x2)
  1112. Obj *x1, *x2;
  1113. {
  1114.     if (!listp(x1))
  1115.       x1 = cons(x1, lispnil);
  1116.     if (!listp(x2))
  1117.       x2 = cons(x2, lispnil);
  1118.     if (x2 == lispnil) {
  1119.     return x1;
  1120.     } else if (x1 == lispnil) {
  1121.     return x2;
  1122.     } else {
  1123.         return cons(car(x1), append_two_lists(cdr(x1), x2));
  1124.     }
  1125. }
  1126.  
  1127. Obj *
  1128. append_lists(lis)
  1129. Obj *lis;
  1130. {
  1131.     if (lis == lispnil) {
  1132.     return lispnil;
  1133.     } else if (!consp(lis)) {
  1134.         return cons(lis, lispnil);
  1135.     } else {
  1136.         return append_two_lists(car(lis), append_lists(cdr(lis)));
  1137.     }
  1138. }
  1139.  
  1140. /* Remove all occurrences of a single object from a given list. */
  1141.  
  1142. Obj *
  1143. remove_from_list(elt, lis)
  1144. Obj *elt, *lis;
  1145. {
  1146.     Obj *tmp;
  1147.  
  1148.     if (lis == lispnil) {
  1149.     return lispnil;
  1150.     } else {
  1151.     tmp = remove_from_list(elt, cdr(lis));
  1152.     if (equal(elt, car(lis))) {
  1153.         return tmp;
  1154.     } else {
  1155.         return cons(car(lis), tmp);
  1156.     }
  1157.     }
  1158. }
  1159.  
  1160. void
  1161. push_binding(lis, key, val)
  1162. Obj **lis, *key, *val;
  1163. {
  1164.     *lis = cons(cons(key, cons(val, lispnil)), *lis);
  1165. }
  1166.  
  1167. void
  1168. push_cdr_binding(lis, key, val)
  1169. Obj **lis, *key, *val;
  1170. {
  1171.     *lis = cons(cons(key, val), *lis);
  1172. }
  1173.  
  1174. void
  1175. push_int_binding(lis, key, val)
  1176. Obj **lis, *key;
  1177. int val;
  1178. {
  1179.     *lis = cons(cons(key, cons(new_number(val), lispnil)), *lis);
  1180. }
  1181.  
  1182. void
  1183. push_key_binding(lis, key, val)
  1184. Obj **lis, *val;
  1185. int key;
  1186. {
  1187.     *lis = cons(cons(intern_symbol(keyword_name(key)), cons(val, lispnil)), *lis);
  1188. }
  1189.  
  1190. void
  1191. push_key_cdr_binding(lis, key, val)
  1192. Obj **lis, *val;
  1193. int key;
  1194. {
  1195.     *lis = cons(cons(intern_symbol(keyword_name(key)), val), *lis);
  1196. }
  1197.  
  1198. void
  1199. push_key_int_binding(lis, key, val)
  1200. Obj **lis;
  1201. int key, val;
  1202. {
  1203.     *lis = cons(cons(intern_symbol(keyword_name(key)), cons(new_number(val), lispnil)),
  1204.                 *lis);
  1205. }
  1206.  
  1207. /* Our version of evaluation derefs symbols and evals through lists,
  1208.    unless the list car is a "special form". */
  1209.  
  1210. Obj *
  1211. eval(x)
  1212. Obj *x;
  1213. {
  1214.     int code;
  1215.     Obj *specialform;
  1216.  
  1217.     switch (x->type) {
  1218.       case SYMBOL:
  1219.     return eval_symbol(x);
  1220.       case CONS:
  1221.     specialform = car(x);
  1222.     if (symbolp(specialform)
  1223.         && !boundp(specialform)
  1224.         && (code = keyword_code(c_string(specialform))) >= 0) {
  1225.         switch (code) {
  1226.           case K_QUOTE:
  1227.         return cadr(x);
  1228.           case K_LIST:
  1229.         return eval_list(cdr(x));
  1230.           case K_APPEND:
  1231.         return append_lists(eval_list(cdr(x)));
  1232.           case K_REMOVE:
  1233.               return remove_from_list(eval(cadr(x)), eval(caddr(x)));
  1234.           default:
  1235.         break;
  1236.         }
  1237.     }
  1238.     /* A dubious default, but convenient. */
  1239.     return eval_list(x);
  1240.       default:
  1241.         /* Everything else evaluates to itself. */
  1242.     return x;
  1243.     }
  1244. }
  1245.  
  1246. /* Some symbols are lazily bound, meaning that they don't get a value
  1247.    until it is first asked for. */
  1248.         
  1249. Obj *
  1250. eval_symbol(sym)
  1251. Obj *sym;
  1252. {
  1253.     if (boundp(sym)) {
  1254.     return symbol_value(sym);
  1255.     } else if (lazy_bind(sym)) {
  1256.         return symbol_value(sym);
  1257.     } else {
  1258.     run_warning("`%s' is unbound, returning self", c_string(sym));
  1259.     /* kind of a hack */
  1260.     return sym;
  1261.     }
  1262. }
  1263.  
  1264. /* List evaluation just blasts straight through the list. */
  1265.  
  1266. Obj *
  1267. eval_list(lis)
  1268. Obj *lis;
  1269. {
  1270.     if (lis == lispnil) {
  1271.     return lispnil;
  1272.     } else {
  1273.     return cons(eval(car(lis)), eval_list(cdr(lis)));
  1274.     }
  1275. }
  1276.  
  1277. int
  1278. eval_boolean_expression(expr, fn, dflt)
  1279. Obj *expr;
  1280. int (*fn) PARAMS ((Obj *)), dflt;
  1281. {
  1282.     char *opname;
  1283.  
  1284.     if (expr == lispnil) {
  1285.     return dflt;
  1286.     } else if (consp(expr) && symbolp(car(expr))) {
  1287.     opname = c_string(car(expr));
  1288.     switch (keyword_code(opname)) {
  1289.       case K_AND:
  1290.         return (eval_boolean_expression(cadr(expr), fn, dflt)
  1291.             && eval_boolean_expression(car(cddr(expr)), fn, dflt));
  1292.       case K_OR:
  1293.         return (eval_boolean_expression(cadr(expr), fn, dflt)
  1294.             || eval_boolean_expression(car(cddr(expr)), fn, dflt));
  1295.       case K_NOT:
  1296.         return !eval_boolean_expression(cadr(expr), fn, dflt);
  1297.       default:
  1298.         return (*fn)(expr);
  1299.     }
  1300.     } else {
  1301.     return (*fn)(expr);
  1302.     }
  1303. }
  1304.  
  1305. int
  1306. interpolate_in_list(val, lis, rslt)
  1307. int val, *rslt;
  1308. Obj *lis;
  1309. {
  1310.     int first, thisin, thisval, nextin, nextval;
  1311.     Obj *rest, *head, *next;
  1312.  
  1313.     first = TRUE;
  1314.     for_all_list(lis, rest) {
  1315.     head = car(rest);
  1316.     thisin = c_number(car(head));
  1317.     thisval = c_number(cadr(head));
  1318.     if (cdr(rest) != lispnil) {
  1319.         next = cadr(rest);
  1320.         nextin = c_number(car(next));
  1321.         nextval = c_number(cadr(next));
  1322.         first = FALSE;
  1323.     } else if (first) {
  1324.         if (val == thisin) {
  1325.         *rslt = thisval;
  1326.         return 0;
  1327.         } else if (val < thisin) {
  1328.         return (-1);
  1329.         } else {
  1330.         return 1;
  1331.         }
  1332.     } else {
  1333.         /* We're at the end of a several-item list; the value
  1334.            must be too high. */
  1335.         return 1;
  1336.     }
  1337.     if (val < thisin) {
  1338.         return (-1);
  1339.     } else if (between(thisin, val, nextin)) {
  1340.         if (val == thisin) {
  1341.         *rslt = thisval;
  1342.         } else if (val == nextin) {
  1343.         *rslt = nextval;
  1344.         } else {
  1345.         *rslt = thisval;
  1346.         if (val != thisin && nextin != thisin) {
  1347.             /* Add the linear interpolation. */
  1348.             *rslt += ((nextval - thisval) * (val - thisin)) / (nextin - thisin);
  1349.         }
  1350.         }
  1351.         return 0;
  1352.     }
  1353.     }
  1354.     return (-1);
  1355. }
  1356.  
  1357. int
  1358. interpolate_in_list_ext(val, lis, mindo, minval, minrslt, maxdo, maxval, maxrslt, rslt)
  1359. int val, mindo, minval, minrslt, maxdo, maxval, maxrslt, *rslt;
  1360. Obj *lis;
  1361. {
  1362.     int first, thisin, thisval, nextin, nextval;
  1363.     Obj *rest, *head, *next;
  1364.  
  1365.     /* (should use the additional parameters) */
  1366.     first = TRUE;
  1367.     for_all_list(lis, rest) {
  1368.     head = car(rest);
  1369.     thisin = c_number(car(head));
  1370.     thisval = c_number(cadr(head));
  1371.     if (cdr(rest) != lispnil) {
  1372.         next = cadr(rest);
  1373.         nextin = c_number(car(next));
  1374.         nextval = c_number(cadr(next));
  1375.         first = FALSE;
  1376.     } else if (first) {
  1377.         if (val == thisin) {
  1378.         *rslt = thisval;
  1379.         return 0;
  1380.         } else if (val < thisin) {
  1381.         return (-1);
  1382.         } else {
  1383.         return 1;
  1384.         }
  1385.     } else {
  1386.         /* We're at the end of a several-item list; the value
  1387.            must be too high. */
  1388.         return 1;
  1389.     }
  1390.     if (val < thisin) {
  1391.         return (-1);
  1392.     } else if (between(thisin, val, nextin)) {
  1393.         if (val == thisin) {
  1394.         *rslt = thisval;
  1395.         } else if (val == nextin) {
  1396.         *rslt = nextval;
  1397.         } else {
  1398.         *rslt = thisval;
  1399.         if (val != thisin && nextin != thisin) {
  1400.             /* Add the linear interpolation. */
  1401.             *rslt += ((nextval - thisval) * (val - thisin)) / (nextin - thisin);
  1402.         }
  1403.         }
  1404.         return 0;
  1405.     }
  1406.     }
  1407.     return (-1);
  1408. }
  1409.  
  1410.