home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / general / modelers / geomview / source.lha / Geomview / src / lib / oogl / lisp / lisp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-12-07  |  42.5 KB  |  2,016 lines
  1. /* Copyright (c) 1992 The Geometry Center; University of Minnesota
  2.    1300 South Second Street;  Minneapolis, MN  55454, USA;
  3.    
  4. This file is part of geomview/OOGL. geomview/OOGL is free software;
  5. you can redistribute it and/or modify it only under the terms given in
  6. the file COPYING, which you should have received along with this file.
  7. This and other related software may be obtained via anonymous ftp from
  8. geom.umn.edu; email: software@geom.umn.edu. */
  9.  
  10. /* Authors: Stuart Levy, Tamara Munzner, Mark Phillips */
  11.  
  12. /*
  13.  * lisp.c: minimal (but less minimal than before) lisp interpreter
  14.  */
  15.  
  16. #include <stdio.h>
  17. #include <string.h>
  18. #include <math.h>
  19. #include <stdlib.h>
  20. #include "lisp.h"
  21. #include "clisp.c"
  22.  
  23. #define MAXPAT 10
  24. #define MAXPATLEN 128
  25.  
  26. typedef struct _pattern {
  27.     int n;
  28.     char p0[MAXPATLEN];
  29.     char *pat[MAXPAT];
  30.     int len[MAXPAT];
  31. } pattern;
  32.  
  33. static int match(char *str, register pattern *p);
  34. static void compile(char *str, register pattern *p);
  35. static int LCompare(char *name, LObject *expr1, LObject *expr2);
  36.  
  37. typedef struct Help {
  38.     char *key;
  39.     char *message;
  40.     struct Help *next;
  41. } Help;
  42.  
  43. static Help *helps = NULL;
  44.  
  45. static char nomatch[] = "No commands match \"%s\"; see \"(? *)\" for list.\n";
  46.  
  47. static int FilterArgMatch(LList *filter, LList *args);
  48. static void InterestOutput(char *name, LList *args, LInterest *interest);
  49.  
  50. static LObject *LFAny, *LFNil;
  51. static LFilter FAny = {ANY, NULL};
  52. static LFilter FNil = {NIL, NULL};
  53.  
  54. static int obj2array(LObject *obj, LType *type, char *x, int *n);
  55. LObject *LMakeArray(LType *basetype, char *array, int count);
  56.  
  57. static char *delims = "()";
  58. #define NEXTTOKEN(tok,fp) tok = fdelimtok( delims, fp, 0 )
  59.  
  60.     /* Use -1 as the item size of special type markers
  61.      * for quick detection in LParseArgs()/AssignArgs().
  62.      */
  63. LType Larray = { NULL, -1 };
  64. LType Lend = { NULL, -1 };
  65. LType Lrest = { NULL, -1 };
  66. LType Lhold = { NULL, -1 };
  67. LType Lliteral = { NULL, -1 };
  68. LType Loptional = { NULL, -1 };
  69.  
  70. #define REJECT -1
  71.  
  72. typedef struct {
  73.   LObjectFunc fptr;
  74.   char *name;
  75.   LInterest *interested;
  76. } LFunction;
  77.  
  78. extern LType LFuncp;
  79. #define LFUNC (&LFuncp)
  80. #define LFUNCVAL(obj) ((int)((obj)->cell.i))
  81.  
  82. vvec funcvvec;
  83. #define functable VVEC(funcvvec,LFunction)
  84.  
  85. static Fsa func_fsa;
  86.  
  87. /*
  88.  * function prototypes
  89.  */
  90.  
  91. static int AssignArgs(char *name, LList *args, va_list a_list);
  92. static int funcindex(char *name);
  93.  
  94. static LObject *LSexpr0(Lake *lake, int listhow);
  95. #define    LIST_LITERAL    0
  96. #define    LIST_FUNCTION    1
  97. #define    LIST_EVAL    2    /* Parse with intention to evaluate */
  98.  
  99. LObject *Linterest(Lake *lake, LList *args);
  100. LObject *Luninterest(Lake *lake, LList *args);
  101. LObject *Lregtable(Lake *lake, LList *args);
  102. static LObject *do_interest(Lake *lake, LList *call, char *action);
  103.  
  104. static void RemoveInterests(LInterest **interest, Lake *lake,
  105.                 int usefilter, LList *filter);
  106. static int InterestMatch(LInterest *interest, Lake *lake,
  107.              int usefilter, LList *filter);
  108. static int FilterMatch(LFilter *f1, LFilter *f2);
  109. static void DeleteInterest(LInterest *interest);
  110. static LInterest *NewInterest();
  111. static void AppendInterest(LInterest **head, LInterest *new);
  112. static LList *FilterList(LList *args);
  113.  
  114.  
  115.  
  116. /*
  117.  * nil object implementation
  118.  */
  119.  
  120. static void nilwrite(FILE *fp, void *value)
  121. {
  122.   fprintf(fp, "nil");
  123. }
  124.  
  125. static LCell nullcell;
  126.  
  127. static LType niltype = {
  128.   "nil",
  129.   sizeof(int),
  130.   NULL,
  131.   NULL,
  132.   NULL,
  133.   nilwrite,
  134.   NULL,
  135.   NULL,
  136.   NULL,
  137.   LTypeMagic
  138.   };
  139. static LObject nil; /* = {&niltype, 1, nullcell }; */
  140. LObject *Lnil = &nil;
  141.  
  142. /*
  143.  * t object implementation
  144.  */
  145.  
  146. static void twrite(FILE *fp, void *value)
  147. {
  148.   fprintf(fp,"t");
  149. }
  150.  
  151. static LType ttype = {
  152.   "t",
  153.   sizeof(int),
  154.   NULL,
  155.   NULL,
  156.   NULL,
  157.   twrite,
  158.   NULL,
  159.   NULL,
  160.   NULL,
  161.   LTypeMagic
  162.   } ;
  163. static LObject t; /* = {&ttype, 1, nullcell }; */
  164. LObject *Lt = &t;
  165.  
  166.  
  167. /*
  168.  * int object implementation
  169.  */
  170.  
  171. static int intfromobj(obj, x)
  172.     LObject *obj;
  173.     int *x;
  174. {
  175.   if (obj->type == LSTRING) {
  176.     char *cp = LSTRINGVAL(obj);
  177.     if (cp[0]=='n' && cp[1]=='i' && cp[2]=='l' && cp[3]=='\0')
  178.       *x = 0;
  179.     else {
  180.       *x = strtol(cp, &cp, 0);
  181.       return cp != LSTRINGVAL(obj) ? 1 : 0;
  182.     }
  183.   } else if (obj->type == LINT) {
  184.     *x = LINTVAL(obj);
  185.   } else return 0;
  186.   return 1;
  187. }
  188.  
  189. static LObject *int2obj(x)
  190.     int *x;
  191. {
  192.   return LNew( LINT, x );
  193. }
  194.  
  195. static void intfree(x)
  196.     int *x;
  197. {}
  198.  
  199. static int intmatch(a, b)
  200.     int *a,*b;
  201. {
  202.   return *a == *b;
  203. }
  204.  
  205. static void intwrite(fp, x)
  206.     FILE *fp;
  207.     int *x;
  208. {
  209.   fprintf(fp, "%1d", *x);
  210. }
  211.  
  212. static void intpull(a_list, x)
  213.     va_list *a_list;
  214.     int *x;
  215. {
  216.   *x = va_arg(*a_list, int);
  217. }
  218.  
  219. LObject *intparse(Lake *lake)
  220. {
  221.   /* parse the next thing from the lake */
  222.   LObject *obj = LSexpr(lake);
  223.  
  224.   /* if it's a string, promote it to an int, otherwise
  225.      leave it as it is */
  226.   if (obj->type == LSTRING) {
  227.     char *cp = LSTRINGVAL(obj);
  228.     int val = strtol(cp, &cp, 0);
  229.     if(cp != LSTRINGVAL(obj)) {        /* if valid int */
  230.     OOGLFree(LSTRINGVAL(obj));
  231.     obj->type = LINT;
  232.     obj->cell.i = val;
  233.     }
  234.   }
  235.   return obj;
  236. }
  237.  
  238. LType LIntp = {
  239.   "int",
  240.   sizeof(int),
  241.   intfromobj,
  242.   int2obj,
  243.   intfree,
  244.   intwrite,
  245.   intmatch,
  246.   intpull,
  247.   intparse,
  248.   LTypeMagic
  249.   };
  250.  
  251. /*
  252.  * float object implementation
  253.  */
  254.  
  255. int floatfromobj(obj, x)
  256.     LObject *obj;
  257.     float *x;
  258. {
  259.   if (obj->type == LSTRING) {
  260.     char *cp = LSTRINGVAL(obj);
  261.     *x = strtod(cp, &cp);
  262.     return cp != LSTRINGVAL(obj) ? 1 : 0;
  263.   } else if (obj->type == LFLOAT) {
  264.     *x = LFLOATVAL(obj);
  265.   } else return 0;
  266.   return 1;
  267. }
  268.  
  269. LObject *float2obj(x)
  270.     float *x;
  271. {
  272.   return LNew( LFLOAT, x );
  273. }
  274.  
  275. void floatfree(x)
  276.     float *x;
  277. {}
  278.  
  279. int floatmatch(a, b)
  280.     float *a,*b;
  281. {
  282.   return *a == *b;
  283. }
  284.  
  285. void floatwrite(fp, x)
  286.     FILE *fp;
  287.     float *x;
  288. {
  289.   fprintf(fp, "%1g", *x);
  290. }
  291.  
  292. void floatpull(a_list, x)
  293.     va_list *a_list;
  294.     float *x;
  295. {
  296.   *x = va_arg(*a_list, double);
  297. }
  298.  
  299. LObject *floatparse(Lake *lake)
  300. {
  301.   /* parse the next thing from the lake */
  302.   LObject *obj = LSexpr(lake);
  303.  
  304.   /* if it's a string or int, promote it to a float, otherwise
  305.      leave it as it is */
  306.   if (obj->type == LSTRING) {
  307.     char *cp = LSTRINGVAL(obj);
  308.     float val = strtod(cp, &cp);
  309.     if(cp != LSTRINGVAL(obj)) {
  310.     OOGLFree(LSTRINGVAL(obj));
  311.     obj->type = LFLOAT;
  312.     obj->cell.f = val;
  313.     }
  314.   } else if (obj->type == LINT) {
  315.     float val = LINTVAL(obj);
  316.     obj->type = LFLOAT;
  317.     obj->cell.f = val;
  318.   }
  319.   return obj;
  320. }
  321.  
  322. LType LFloatp = {
  323.   "float",
  324.   sizeof(float),
  325.   floatfromobj,
  326.   float2obj,
  327.   floatfree,
  328.   floatwrite,
  329.   floatmatch,
  330.   floatpull,
  331.   floatparse,
  332.   LTypeMagic
  333.   };
  334.  
  335. /*
  336.  * string object implementation
  337.  */
  338.  
  339. int stringfromobj(obj, x)
  340.     LObject *obj;
  341.     char * *x;
  342. {
  343.   if (obj->type != LSTRING) return 0;
  344.   *x = LSTRINGVAL(obj);
  345.   return 1;
  346. }
  347.  
  348. LObject *string2obj(x)
  349.     char * *x;
  350. {
  351.   char *copy = *x ? strdup(*x) : NULL;
  352.   return LNew( LSTRING, © );
  353. }
  354.  
  355. void stringfree(x)
  356.     char * *x;
  357. {
  358.   if (*x) free(*x);
  359. }
  360.  
  361. int stringmatch(a, b)
  362.     char **a,**b;
  363. {
  364.   if (!*a) return *b==NULL;
  365.   if (!*b) return *a==NULL;
  366.   return strcmp(*a,*b)==0 ;
  367. }
  368.  
  369. void stringwrite(fp, x)
  370.     FILE *fp;
  371.     char * *x;
  372. {
  373.   fprintf(fp, "\"%s\"", *x);
  374. }
  375.  
  376. void stringpull(a_list, x)
  377.     va_list *a_list;
  378.     char * *x;
  379. {
  380.   *x = va_arg(*a_list, char *);
  381. }
  382.  
  383. LType LStringp = {
  384.   "string",
  385.   sizeof(char *),
  386.   stringfromobj,
  387.   string2obj,
  388.   stringfree,
  389.   stringwrite,
  390.   stringmatch,
  391.   stringpull,
  392.   LSexpr,
  393.   LTypeMagic
  394.   };
  395.  
  396. /*
  397.  * list implementation
  398.  */
  399.  
  400. LList *LListCopy(LList *list)
  401. {
  402.   LList *new;
  403.  
  404.   if (! list) return NULL;
  405.   new = LListNew();
  406.   if (list->car)
  407.     new->car = LCopy(list->car);
  408.   new->cdr = LListCopy(list->cdr);
  409.   return (void*)new;
  410. }
  411.  
  412. void LListFree(LList *list)
  413. {
  414.   if (!list) return;
  415.   if (list->cdr) LListFree(list->cdr);
  416.   LFree(list->car);
  417.   free(list);
  418. }
  419.  
  420. void LListWrite(fp, list)
  421.      FILE *fp;
  422.      LList *list;
  423. {
  424.   int first = 1;
  425.   fprintf(fp,"(");
  426.   while (list != NULL) {
  427.     if (!first) {
  428.       fprintf(fp," ");
  429.     }
  430.     first = 0;
  431.     LWrite(fp, list->car);
  432.     list = list->cdr;
  433.   }
  434.   fprintf(fp,")");
  435. }
  436.  
  437. /**********************************************************************/
  438.  
  439. int listfromobj(obj, x)
  440.     LObject *obj;
  441.     LList * *x;
  442. {
  443.   if (obj->type != LLIST) return 0;
  444.   *x = LLISTVAL(obj);
  445.   return 1;
  446. }
  447.  
  448. LObject *list2obj(x)
  449.     LList * *x;
  450. {
  451.   LList *list = *x ? LListCopy(*x) : NULL;
  452.   return LNew( LLIST, &list );
  453. }
  454.  
  455. void listfree(x)
  456.     LList * *x;
  457. {
  458.   if (*x) LListFree(*x);
  459. }
  460.  
  461.  
  462. int listmatch(a, b)
  463.     LList **a,**b;
  464. {
  465.   return *a == *b;
  466. }
  467.  
  468. void listwrite(fp, x)
  469.     FILE *fp;
  470.     LList * *x;
  471. {
  472.   LListWrite(fp, *x);
  473. }
  474.  
  475. void listpull(a_list, x)
  476.     va_list *a_list;
  477.     LList * *x;
  478. {
  479.   *x = va_arg(*a_list, LList *);
  480. }
  481.  
  482. LType LListp = {
  483.   "list",
  484.   sizeof(LList *),
  485.   listfromobj,
  486.   list2obj,
  487.   listfree,
  488.   listwrite,
  489.   listmatch,
  490.   listpull,
  491.   LSexpr,
  492.   LTypeMagic
  493.   };
  494.  
  495. int objfromobj(obj, x)
  496.     LObject *obj;
  497.     LObject * *x;
  498. {
  499.   *x = LRefIncr(obj);
  500.   return 1;
  501. }
  502.  
  503. LObject *obj2obj(x)
  504.     LObject * *x;
  505. {
  506.   if (*x) LRefIncr(*x);
  507.   return *x;
  508. }
  509.  
  510. void objpull(a_list, x)
  511.     va_list *a_list;
  512.     LObject * *x;
  513. {
  514.   *x = va_arg(*a_list, LObject *);
  515. }
  516.  
  517. int objmatch(a, b)
  518.     LObject **a,**b;
  519. {
  520.   return *a == *b;
  521. }
  522.  
  523. LType LObjectp = {
  524.   "lisp object",
  525.   sizeof(LObject *),
  526.   objfromobj,
  527.   obj2obj,
  528.   NULL,
  529.   NULL,
  530.   objmatch,
  531.   objpull,
  532.   LSexpr,
  533.   LTypeMagic
  534.   };
  535.  
  536. /*
  537.  * Lake implementation
  538.  */
  539.  
  540. Lake *LakeDefine(FILE *streamin, FILE *streamout, void *river)
  541. {
  542.   Lake *lake = OOGLNewE(Lake, "new Lake");
  543.   lake->streamin = streamin;
  544.   lake->streamout = streamout;
  545.   lake->river = river;
  546.   lake->timing_interests = 0;
  547.   return lake;
  548. }
  549.  
  550. void LakeFree(Lake *lake)
  551. {
  552.   OOGLFree(lake);
  553. }
  554.  
  555.  
  556. /*
  557.  * Lake object implementation
  558.  *   ( Not the same as the Lake itself; the lake object is a lisp
  559.  *     object type whose value is a Lake pointer. )
  560.  */
  561.  
  562.  
  563. int lakefromobj(obj, x)
  564.     LObject *obj;
  565.     Lake * *x;
  566. {
  567.   *x = LLAKEVAL(obj);
  568.   return 1;
  569. }
  570.  
  571. LObject *lake2obj(x)
  572.     Lake * *x;
  573. {
  574.   return LNew( LLAKE, x );
  575. }
  576.  
  577. void lakefree(x)
  578.     Lake * *x;
  579. {}
  580.  
  581. void lakewrite(fp, x)
  582.     FILE *fp;
  583.     Lake * *x;
  584. {
  585.   fprintf(fp,"-lake-");
  586. }
  587.  
  588.  
  589. LType LLakep = {
  590.   "lake",
  591.   sizeof(Lake *),
  592.   lakefromobj,
  593.   lake2obj,
  594.   lakefree,
  595.   lakewrite,
  596.   NULL,
  597.   NULL,
  598.   NULL,
  599.   LTypeMagic
  600.   };
  601.  
  602. /*
  603.  * function object implementation
  604.  */
  605.  
  606. int funcfromobj(obj, x)
  607.     LObject *obj;
  608.     int *x;
  609. {
  610.   if (obj->type == LSTRING) {
  611.     *x = funcindex(LSTRINGVAL(obj));
  612.     if (*x == REJECT) return 0;
  613.   } else if (obj->type == LFUNC) {
  614.     *x = LFUNCVAL(obj);
  615.   } else return 0;
  616.   return 1;
  617. }
  618.  
  619. LObject *func2obj(x)
  620.     int *x;
  621. {
  622.   return LNew( LFUNC, x );
  623. }
  624.  
  625. void funcfree(x)
  626.     int *x;
  627. {}
  628.  
  629. int funcmatch(a, b)
  630.     int *a,*b;
  631. {
  632.   return *a == *b;
  633. }
  634.  
  635. void funcwrite(fp, x)
  636.     FILE *fp;
  637.     int *x;
  638. {
  639.   fprintf(fp, "%s", functable[*x].name);
  640. }
  641.  
  642. void funcpull(a_list, x)
  643.     va_list *a_list;
  644.     int *x;
  645. {
  646.   *x = va_arg(*a_list, int);
  647. }
  648.  
  649. LType LFuncp = {
  650.   "lisp function",
  651.   sizeof(int),
  652.   funcfromobj,
  653.   func2obj,
  654.   funcfree,
  655.   funcwrite,
  656.   funcmatch,
  657.   funcpull,
  658.   LSexpr,
  659.   LTypeMagic
  660.   };
  661.  
  662. /**********************************************************************/
  663.  
  664. void LInit()
  665. {
  666.   VVINIT(funcvvec, LFunction, 30);
  667.   func_fsa = fsa_initialize( NULL, (void*)REJECT );
  668.  
  669.   nullcell.p = NULL;
  670.   nil.type = &niltype;
  671.   nil.cell = nullcell;
  672.   t.type = &ttype;
  673.   t.cell = nullcell;
  674.  
  675.   {
  676.     LCell cell;
  677.     cell.p = (void*)(&FAny);
  678.     LFAny = LNew(LFILTER, &cell);
  679.     cell.p = (void*)(&FNil);
  680.     LFNil = LNew(LFILTER, &cell);
  681.   }
  682.  
  683.   {
  684.     extern LObject *Lhelp(Lake *lake, LList *args);
  685.     extern LObject *Lmorehelp(Lake *lake, LList *args);
  686.     LDefun("?", Lhelp,
  687.        "(?  [command])\n\
  688.     Command may include \"*\"s as wildcards; see also \"??\"\n\
  689.     One-line command help; lists names only if multiple commands match.\n\
  690.     ? is a synonym for \"help\"");
  691.     LDefun("??", Lmorehelp,
  692.     "(?? command)  \"command\" may include \"*\" wildcards\n\
  693.     Prints more info than \"(? command)\".  ?? is a synonym\n\
  694.     for \"morehelp\"");
  695.   }
  696.  
  697.   clisp_init();
  698.  
  699.   LHelpDef("STATEMENT",
  700.        "STATEMENT represents a function call.  Function calls have\n\
  701.        the form \"( func arg1 arg2 ... )\", where func is the name\n\
  702.        of the function and arg1, arg2, ... are the arguments.");
  703.  
  704. }
  705.   
  706. LDEFINE(quote, LLOBJECT,
  707.        "(quote EXPR)\n\
  708.     returns the symbolic lisp expression EXPR without evaluating it.")
  709. {
  710.   LObject *arg;
  711.  
  712.   LDECLARE(("quote", lake, args,
  713.         LLITERAL, LLOBJECT, &arg,
  714.         LEND));
  715.   LRefIncr(arg);
  716.   return arg;
  717. }
  718.  
  719. LDEFINE(if, LVOID,
  720.     "(if TEST EXPR1 [EXPR2])\n\
  721.     Evaluates TEST; if TEST returns a non-nil value, returns the\n\
  722.     value of EXPR1.  If TEST returns nil, returns the value of\n\
  723.     EXPR2 if EXPR2 is present, otherwise returns nil.")
  724. {
  725.   LObject *test, *tclause, *fclause=NULL;
  726.   LDECLARE(("if", LBEGIN,
  727.         LLOBJECT, &test,
  728.         LHOLD, LLOBJECT, &tclause,
  729.         LOPTIONAL,
  730.         LHOLD, LLOBJECT, &fclause,
  731.         LEND));
  732.   if (test != Lnil) {
  733.     return LEval(tclause);
  734.   } else if (fclause) {
  735.     return LEval(fclause);
  736.   } else {
  737.     return Lnil;
  738.   }
  739. }
  740.  
  741. LDEFINE(greater, LINT,
  742.     "(> EXPR1 EXPR2)\n\
  743.     Returns t if EXPR1 is greater than EXPR2.  EXPR1 and EXPR2 should\n\
  744.     be either both integers or floats, or both strings.")
  745. {
  746.   LObject *expr1, *expr2;
  747.   LDECLARE((">", LBEGIN,
  748.         LLOBJECT, &expr1,
  749.         LLOBJECT, &expr2,
  750.         LEND));
  751.   if (LCompare(">", expr1, expr2)==1) return Lt;
  752.   else return Lnil;
  753. }
  754.  
  755. LDEFINE(less, LINT,
  756.     "(< EXPR1 EXPR2)\n\
  757.     Returns t if EXPR1 is less than EXPR2.  EXPR1 and EXPR2 should\n\
  758.     be either both integers or floats, or both strings.")
  759. {
  760.   LObject *expr1, *expr2;
  761.   LDECLARE(("<", LBEGIN,
  762.         LLOBJECT, &expr1,
  763.         LLOBJECT, &expr2,
  764.         LEND));
  765.   if (LCompare("<", expr1, expr2)==-1) return Lt;
  766.   else return Lnil;
  767. }
  768.  
  769. LDEFINE(equal, LINT,
  770.     "(= EXPR1 EXPR2)\n\
  771.     Returns t if EXPR1 is equal to EXPR2.  EXPR1 and EXPR2 should\n\
  772.     be either both integers or floats, or both strings.")
  773. {
  774.   LObject *expr1, *expr2;
  775.   LDECLARE(("=", LBEGIN,
  776.         LLOBJECT, &expr1,
  777.         LLOBJECT, &expr2,
  778.         LEND));
  779.   if (LCompare("=", expr1, expr2)==0) return Lt;
  780.   else return Lnil;
  781. }
  782.  
  783. static int LCompare(char *name, LObject *expr1, LObject *expr2)
  784. {
  785.   char *s1, *s2;
  786.   float e1, e2;
  787.   if (expr1->type == LSTRING && expr2->type == LSTRING) {
  788.     s1 = LSTRINGVAL(expr1);
  789.     s2 = LSTRINGVAL(expr2);
  790.     return -strcmp(s1,s2);
  791.   }
  792.   if (expr1->type == LINT) e1 = LINTVAL(expr1);
  793.   else if (expr1->type == LFLOAT) e1 = LFLOATVAL(expr1);
  794.   else {
  795.     OOGLError(0, "%s: arg 1 must be int, float, or string\n", name);
  796.     return -2;
  797.   }
  798.   if (expr2->type == LINT) e2 = LINTVAL(expr2);
  799.   else if (expr2->type == LFLOAT) e2 = LFLOATVAL(expr2);
  800.   else {
  801.     OOGLError(0, "%s: arg 2 must be int, float, or string\n", name);
  802.     return -2;
  803.   }
  804.   if (e1 == e2) return 0;
  805.   else if (e1 > e2) return 1;
  806.   else return -1;
  807. }
  808.  
  809. LDEFINE(sgi, LINT,
  810.     "(sgi)\n\
  811.     Returns t if running on an sgi machine, nil if not")
  812. {
  813.   LDECLARE(("sgi", LBEGIN,
  814.         LEND));
  815.   if (strcmp(MACHTYPE,"sgi")==0) return Lt;
  816.   return Lnil;
  817. }
  818.  
  819. LDEFINE(NeXT, LINT,
  820.     "(NeXT)\n\
  821.     Returns t if running on a NeXT, nil if not")
  822. {
  823.   LDECLARE(("NeXT", LBEGIN,
  824.         LEND));
  825.   if (strcmp(MACHTYPE,"next")==0) return Lt;
  826.   return Lnil;
  827. }
  828.  
  829.  
  830.  
  831. LDEFINE(progn, LLOBJECT,
  832.        "(progn STATEMENT [ ... ])\n\
  833.     evaluates each STATEMENT in order and returns the value of the\n\
  834.     last one.  Use progn to group a collection of commands together,\n\
  835.     forcing them to be treated as a single command.")
  836. {
  837.   LObject *val=NULL;
  838.   LList *arglist = NULL;
  839.  
  840.   LDECLARE(("progn", LBEGIN,
  841.     LHOLD,
  842.     LREST, &arglist,
  843.     LEND));
  844.   for( ; arglist != NULL; arglist = arglist->cdr) {
  845.     LFree(val);
  846.     val = LEval(arglist->car);
  847.   }
  848.   return val;
  849. }
  850.  
  851. void LListShow(LList *list)
  852. {
  853.   LListWrite(stderr,list);
  854. }
  855.  
  856. /*
  857.  * Lisp object implementation
  858.  */
  859.  
  860. LObject *_LNew(LType *type, LCell *cell)
  861. {
  862.   LObject *obj = (LObject*)malloc(sizeof(LObject));
  863.   obj->type = type;
  864.   obj->ref = 1;
  865.   if (!cell) obj->cell.p = NULL;
  866.   else obj->cell = *cell;
  867.   return obj;
  868. }
  869.  
  870. void LWrite(FILE *fp, LObject *obj)
  871. {
  872.   (*obj->type->write)(fp, &(obj->cell));
  873. }
  874.  
  875. void LWriteFile(char *fname, LObject *obj)
  876. {
  877.   FILE *fp = fopen(fname, "w");
  878.   if (fp != NULL) {
  879.     LWrite(fp, obj);
  880.     fclose(fp);
  881.   } else {
  882.     OOGLError(0, "LWriteFile: can't create file %s",fname);
  883.   }
  884. }
  885.  
  886. void LShow(LObject *obj)
  887. {
  888.   LWrite(stderr, obj);
  889. }
  890.  
  891. void LFree(LObject *obj)
  892. {
  893.   if (obj == NULL || obj == Lnil || obj == Lt) return;
  894.   LRefDecr(obj);
  895.   if ( obj->ref == 0 ) {
  896.     (*obj->type->free)(&(obj->cell));
  897.     OOGLFree(obj);
  898.   }
  899. }
  900.  
  901. LObject *LCopy(LObject *obj)
  902. {
  903.   if (obj == Lnil) return Lnil;
  904.   if (obj == Lt) return Lt;
  905.   return LTOOBJ(obj->type)(&(obj->cell));
  906. }
  907.  
  908. LObject *LRefIncr(LObject *obj)
  909. {
  910.   ++(obj->ref);
  911.   return obj;
  912. }
  913.  
  914. void LRefDecr(LObject *obj)
  915. {
  916.   --(obj->ref);
  917. }
  918.  
  919. /* LSexpr() uses special parsing on lists; changes function names to
  920.    function pointers, and calls the function to parse the arguments */
  921. LObject *LSexpr(Lake *lake)
  922. {
  923.   return LSexpr0(lake, LIST_FUNCTION);
  924. }
  925.   
  926. /* LLiteral() uses literal parsing; lists are not interpreted
  927.    as function calls */
  928. LObject *LLiteral(Lake *lake)
  929. {
  930.   return LSexpr0(lake, LIST_LITERAL);
  931. }
  932.  
  933. /* LEvalSexpr() both parses and evaluates the requested expression. */
  934. LObject *LEvalSexpr(Lake *lake)
  935. {
  936.   LObject *args, *val;
  937.  
  938.   args = LSexpr0(lake, LIST_EVAL);
  939.   val = LEval(args);
  940.   LFree(args);
  941.   return val;
  942. }
  943.  
  944.  
  945. /* LSexpr0() does the work of both LSexpr() and LLiteral();
  946.    special says whether to interpret lists specially */
  947. static LObject *LSexpr0(Lake *lake, int listhow)
  948. {
  949.   LObject *obj, *head;
  950.   char *tok;
  951.   int i, c;
  952.   
  953.   NEXTTOKEN(tok,lake->streamin);
  954.   if(tok == NULL)
  955.     return Lnil;
  956.   if (*tok == '(' && tok[1] == '\0') {
  957.     obj = LNew(LLIST, NULL);
  958.     if(listhow == LIST_LITERAL) {
  959.     while ( LakeMore(lake,c) )
  960.         obj->cell.p = (void*) LListAppend((LList*)(obj->cell.p),
  961.                      LSexpr0(lake,LIST_LITERAL));
  962.     } else if ( LakeMore(lake,c) ) {
  963.       /* if we have a non-empty list ... */
  964.     /* ... get the first element and see if it's a function name */
  965.     head = LEvalSexpr(lake);
  966.     if (funcfromobj(head, &i)) {
  967.       /* It's a function name.  Enter the function as the first element
  968.          of our list, and then call the function in parse mode to
  969.          construct the rest of the list (arguments to the function) */
  970.         if(head->type != LFUNC) {
  971.         LFree(head);
  972.         head = LNew(LFUNC, &i);
  973.         }
  974.         obj->cell.p = (void*) LListAppend(LLISTVAL(obj), head);
  975.         if ( (*functable[i].fptr)(lake, LLISTVAL(obj)) == Lnil ) {
  976.         LFree(obj);
  977.         obj = Lnil;
  978.         }
  979.     } else {
  980.       /* It's not a function name.  Probably this part will only
  981.          be called in error, because plain lists should always be
  982.          quoted.  This should probably be replaced by more robust
  983.          error detection and recovery code.  For now, just parse
  984.          as a plain list.  LEval() will emit an error message if
  985.          this list is ever evaluated. */
  986.       if(listhow == LIST_EVAL)
  987.          OOGLSyntax(lake->streamin, "Reading \"%s\": call to unknown function \"%s\"",
  988.         LakeName(lake), LSummarize(head));
  989.       obj->cell.p = (void*) LListAppend(LLISTVAL(obj), head);
  990.       while ( LakeMore(lake,c) )
  991.         obj->cell.p = (void*) LListAppend(LLISTVAL(obj),
  992.                          LSexpr0(lake,listhow));
  993.     }
  994.     }
  995.     NEXTTOKEN(tok,lake->streamin);
  996.   } else {
  997.     obj = LNew(LSTRING, NULL);
  998.     obj->cell.p = strdup(tok);
  999.   }
  1000.   return obj;
  1001. }
  1002.  
  1003. LObject *LEval(LObject *obj)
  1004. {
  1005.   LObject *ans;
  1006.   LList *list, *args;
  1007.   LInterest *interest;
  1008.   LFunction *fentry;
  1009.  
  1010.   /* all non-list objects evaluate to themselves */
  1011.   if (obj->type != LLIST) {
  1012.     LRefIncr(obj);
  1013.     return obj;
  1014.   }
  1015.  
  1016.   list = LLISTVAL(obj);
  1017.  
  1018.   /* the empty list evaluates to itself */
  1019.   if (list == NULL || list->car == NULL) return obj;
  1020.  
  1021.   /* a nonempty list corresponds to a function call;
  1022.      the list's value is the value returned by the function */
  1023.   if (list->car->type == LFUNC) {
  1024.     fentry = &functable[LFUNCVAL(list->car)];
  1025.     args = LLISTVAL(obj)->cdr;
  1026.  
  1027.     /* deal with any interests in the function first */
  1028.     if ((interest=fentry->interested) != NULL) {
  1029.       while (interest) {
  1030.     if (FilterArgMatch(interest->filter, args)) {
  1031.       InterestOutput(fentry->name, args, interest);
  1032.     }
  1033.     interest = interest->next;
  1034.       }
  1035.     }
  1036.  
  1037.     /* then call the function */
  1038.     ans = (*(fentry->fptr))( NULL, args );
  1039.     return ans;
  1040.   } else {
  1041.     OOGLError(0, "lisp error: call to unknown function %s", LSummarize(list->car));
  1042.     return Lnil;
  1043.   }
  1044. }
  1045.  
  1046. LList *LListNew()
  1047. {
  1048.   LList *new = (LList*)malloc(sizeof(LList));
  1049.   new->cdr = NULL;
  1050.   return new;
  1051. }
  1052.  
  1053. LList *LListAppend(LList *list, LObject *obj)
  1054. {
  1055.   LList *l, *new = LListNew();
  1056.  
  1057.   new->car = obj;
  1058.   l = list;
  1059.   if (l) {
  1060.     while (l->cdr) l = l->cdr;
  1061.     l->cdr = new;
  1062.     return list;
  1063.   }
  1064.   return new;
  1065. }
  1066.  
  1067. int LListLength(LList *list)
  1068. {
  1069.   int n=0;
  1070.   while (list) {
  1071.     ++n;
  1072.     list = list->cdr;
  1073.   }
  1074.   return n;
  1075. }
  1076.  
  1077. LObject *LListEntry(LList *list, int n)
  1078. {
  1079.   if (n < 0) n = LListLength(list) + 1 + n;
  1080.   while (list && --n) list = list->cdr;
  1081.   if (list) return list->car;
  1082.   else return NULL;
  1083. }
  1084.  
  1085. LDEFINE(car, LLOBJECT,
  1086.     "(car LIST)\n\
  1087.     returns the first element of LIST.")
  1088. {
  1089.   LList *list;
  1090.   LDECLARE(("car", LBEGIN,
  1091.         LLIST, &list,
  1092.         LEND));
  1093.   if (list && list->car) {
  1094.     return LCopy(list->car);
  1095.   }
  1096.   return Lnil;
  1097. }
  1098.  
  1099. LDEFINE(cdr, LLOBJECT,
  1100.     "(cdr LIST)\n\
  1101.     returns the list obtained by removing the first element of LIST.")
  1102. {
  1103.   LList *list;
  1104.   LDECLARE(("cdr", LBEGIN,
  1105.         LLIST, &list,
  1106.         LEND));
  1107.   if (list && list->cdr) {
  1108.     LList *copy = LListCopy(list->cdr);
  1109.     return LNew(LLIST, ©);
  1110.   }
  1111.   return Lnil;
  1112. }
  1113.  
  1114. /*
  1115.  * function definition implementation
  1116.  */
  1117.  
  1118. int LDefun(char *name, LObjectFunc func, char *help)
  1119. {
  1120.   int index = VVCOUNT(funcvvec)++;
  1121.   LFunction *lfunction = VVINDEX(funcvvec, LFunction, index);
  1122.   lfunction->fptr = func;
  1123.   lfunction->name = strdup(name);
  1124.   lfunction->interested = NULL;
  1125.   fsa_install( func_fsa, name, (void *)index );
  1126.   if (help) LHelpDef(name, help);
  1127.   return 1;
  1128. }
  1129.  
  1130. /* Function is called in one of three modes:
  1131.    lake != NULL, args != NULL: parse mode
  1132.      In this mode, upon entry args is a list containing one element,
  1133.      the function object itself.  We parse arguments from lake,
  1134.      appending them to the args list.  We return Lt if the parsing was
  1135.      successful, Lnil if not.
  1136.    lake == NULL: evaluate mode
  1137.      In this mode, upon entry args is a list containing the arguments
  1138.      to the function.  We return the function's value on the arguments.
  1139. */
  1140.  
  1141. static int funcindex(char *name)
  1142. {
  1143.   return (int)fsa_parse( func_fsa, name );
  1144. }
  1145.  
  1146. /*
  1147.  * The LDECLARE() macro calls this function.
  1148.  */
  1149. int LParseArgs(char *name, Lake *lake, LList *args, ...)
  1150. {
  1151.   int c, moreargspecs=1, argsgot=0, argsrequired= -1;
  1152.   LType *argclass;
  1153.   int argspecs=0, literal=0, hold = 0;
  1154.   LObject *arg;
  1155.   va_list a_list;
  1156.  
  1157.   va_start(a_list, args);
  1158.   
  1159.   if (lake == NULL) {
  1160.     int val = AssignArgs(name, args, a_list);
  1161.     va_end(a_list);
  1162.     return val;
  1163.   }
  1164.   
  1165.   while (moreargspecs) {
  1166.     argclass=va_arg(a_list, LType *);
  1167.     if (argclass->size < 0) {
  1168.     if (argclass == LEND) {
  1169.       moreargspecs = 0;
  1170.     } else if (argclass == LOPTIONAL) {
  1171.       argsrequired = argspecs;
  1172.     } else if (argclass == LHOLD) {
  1173.       hold = 1;
  1174.     } else if (argclass == LLITERAL) {
  1175.       /* literal affects the way an argument is parsed (as well as
  1176.          implying "hold" in the assignment stage).  It should only be
  1177.          used on LLOBJECT or LLIST.  It means parse the
  1178.          argument literally.  In non-literal parsing, lists are
  1179.          treated as function calls and the function is called to parse
  1180.          the arguments.  In literal parsing, we don't treat lists as
  1181.          function calls.  Just parse them as lists.  */
  1182.       literal = 1;
  1183.     } else if (argclass == LARRAY) {
  1184.       /* special case for this because it takes 3 args: the base type,
  1185.          the array itself, and a count */
  1186.         va_arg(a_list, LType *);
  1187.         va_arg(a_list, void *);
  1188.         va_arg(a_list, int *);
  1189.  
  1190.         ++argspecs;
  1191.         if (LakeMore(lake,c)) {
  1192.         LListAppend(args, LSexpr(lake));
  1193.         ++argsgot;
  1194.         }
  1195.     } else if(argclass == LREST) {
  1196.         /*
  1197.          * Gather up any remaining arguments into an LList.
  1198.          * If the caller provides a NULL pointer, discard them;
  1199.          * otherwise store the list there.  Note that we yield an LList,
  1200.          * not an LLIST-typed LObject.
  1201.          */
  1202.         LList **restp = va_arg(a_list, LList **);
  1203.  
  1204.         while(LakeMore(lake,c)) {
  1205.         arg = hold||literal ? LSexpr(lake) : LEvalSexpr(lake);
  1206.         LListAppend(args, arg);    /* Stash args for AssignArgs to grab */
  1207.         }
  1208.         moreargspecs = 0;
  1209.     }
  1210.     } else if(argclass == LLAKE) {
  1211.     va_arg(a_list, Lake **);
  1212.     LListAppend(args, LTOOBJ(LLAKE)(&lake));
  1213.     } else {
  1214.       ++argspecs;
  1215.       va_arg(a_list, void *);
  1216.       if (LakeMore(lake,c)) {
  1217.     LObject *arg;
  1218.  
  1219.     if (literal) {
  1220.       /* literal should only be used on LLOBJECT or LLIST
  1221.          types, both of which use the LSexpr() parse method; in
  1222.          the literal case, we use LLiteral() instead. */
  1223.       arg = LLiteral(lake);
  1224.       literal=0;
  1225.     } else {
  1226.       LObject *parsed = arg = LPARSE(argclass)(lake);
  1227.       if(!hold && parsed->type == LLIST) {
  1228.         arg = LEval(parsed);
  1229.         LFree(parsed);
  1230.       }
  1231.     }
  1232.     LListAppend(args, arg);
  1233.     ++argsgot;
  1234.       }
  1235.     }
  1236.   }
  1237.   if (argsrequired<0) argsrequired = argspecs;
  1238.   va_end(a_list);
  1239.   if (argsgot < argsrequired) {
  1240.     OOGLSyntax(lake->streamin, "Reading from \"%s\": %s requires %d args, got %d",
  1241.     PoolName(POOL(lake)),name,argsrequired,argsgot);
  1242.     return LPARSE_BAD;
  1243.   }
  1244.   if (LakeMore(lake,c)) {
  1245.     OOGLSyntax(lake->streamin, "In \"%s\": %s: ignoring additional arguments (expected %1d)\n",
  1246.         PoolName((Pool *)(lake->river)), name, argsgot);
  1247.     while (LakeMore(lake,c)) LFree(LSexpr(lake));
  1248.   }
  1249.   return LPARSE_GOOD;
  1250. }
  1251.  
  1252. static int obj2array(LObject *obj, LType *type, char *x, int *n)
  1253. {
  1254.   int max= abs(*n);
  1255.   LList *list;
  1256.  
  1257.   *n = 0;
  1258.  
  1259.   /* interpret the nil object as an empty list */
  1260.   if (   (obj == Lnil)
  1261.       || (obj->type==LSTRING && strcmp(LSTRINGVAL(obj),"nil")==0) ) {
  1262.     return 1;
  1263.   }
  1264.   
  1265.   list = LLISTVAL(obj);
  1266.   if (obj->type != LLIST) return 0;
  1267.   while (list && list->car && *n<max) {
  1268.     if (!LFROMOBJ(type)(list->car, (void*)(x + (*n)*LSIZE(type)))) return 0;
  1269.     (*n)++;
  1270.     list = list->cdr;
  1271.   }
  1272.   return 1;
  1273. }
  1274.  
  1275. LObject *LMakeArray(LType *basetype, char *array, int count)
  1276. {
  1277.   int i;
  1278.   LList *list = NULL;
  1279.   LObject *obj;
  1280.  
  1281.   for (i=0; i<count; ++i) {
  1282.     obj = LTOOBJ(basetype)((void*)(array + i*LSIZE(basetype)));
  1283.     list = LListAppend(list, obj);
  1284.   }
  1285.   return LNew(LLIST, &list);
  1286. }
  1287.  
  1288. static int AssignArgs(char *name, LList *args, va_list a_list)
  1289. {
  1290.   LObject *arg;
  1291.   int moreargspecs=1, argsgot=0, argsrequired= -1, hold=0;
  1292.   LType *argtype;
  1293.   int argspecs=0, convok;
  1294.   
  1295.   while (moreargspecs) {
  1296.     argtype=va_arg(a_list, LType *);
  1297.     if (argtype->size < 0) {
  1298.     if (argtype == LEND) {
  1299.       moreargspecs = 0;
  1300.     } else if (argtype == LOPTIONAL) {
  1301.       argsrequired = argspecs;
  1302.     } else if (argtype == LHOLD) {
  1303.       hold=1;
  1304.     } else if (argtype == LLITERAL) {
  1305.       /* in the assignment stage, literal means the same as hold */
  1306.       hold=1;
  1307.     } else if (argtype == LLAKE) {
  1308.       if (args) {
  1309.         arg = args->car;
  1310.         *va_arg(a_list, Lake **) = LLAKEVAL(arg);
  1311.         args = args->cdr;
  1312.       } else {
  1313.         OOGLError(0,"%s: internal lake assignment out of whack.  Please\n\
  1314.     report this error!",name);
  1315.         goto bad;
  1316.       }
  1317.     } else if (argtype == LARRAY) {
  1318.       /* get the base type of the array */
  1319.       argtype=va_arg(a_list, LType *);
  1320.       ++argspecs;
  1321.       if (args) {
  1322.         void *array = va_arg(a_list, void*);
  1323.         int *count = va_arg(a_list, int*);
  1324.         int origcount = abs(*count);
  1325.         if (hold) {
  1326.           arg = LRefIncr(args->car);
  1327.         } else {
  1328.           arg = LEval(args->car);
  1329.         }
  1330.         ++argsgot;
  1331.         convok = obj2array(arg, argtype, array, count);
  1332.         if (!convok) {
  1333.           OOGLError(0, "%s: array of at most %1d %ss expected in\n\
  1334.      arg position %1d (got %s)\n", name,origcount, argtype->name, argsgot,
  1335.               LSummarize(arg));
  1336.         }
  1337.         args = args->cdr;
  1338.         hold = 0;
  1339.       } else {
  1340.         va_arg(a_list, void *);
  1341.         va_arg(a_list, void *);
  1342.       }
  1343.     } else if(argtype == LREST) {
  1344.         LList **restp = va_arg(a_list, LList **);
  1345.         if(restp)
  1346.         *restp = args;
  1347.         moreargspecs = 0;
  1348.         args = NULL;        /* Don't complain of excess args */
  1349.     }
  1350.     } else {
  1351.       ++argspecs;
  1352.       if (args) {
  1353.     if (hold) {
  1354.       arg = LRefIncr(args->car);
  1355.     } else {
  1356.       arg = LEval(args->car);
  1357.     }
  1358.     ++argsgot;
  1359.     convok = LFROMOBJ(argtype)(arg, va_arg(a_list, void *));
  1360.     if (!convok) {
  1361.       OOGLError(0,"%s: %s expected in arg position %1d (got %s)\n",
  1362.           name,LNAME(argtype),argsgot,LSummarize(arg));
  1363.       LFree(arg);
  1364.       goto bad;
  1365.     }
  1366.     LFree(arg);
  1367.     args = args->cdr;
  1368.     hold = 0;
  1369.       } else
  1370.     va_arg(a_list, void *);
  1371.     }
  1372.   }
  1373.   if (argsrequired<0) argsrequired = argspecs;
  1374.   va_end(a_list);
  1375.   if (argsgot < argsrequired) {
  1376.     OOGLError(0,"%s: internal argument list deficit; require %1d, got %1d\n\
  1377. Please report this error!", name, argsrequired, argsgot);
  1378.     goto bad;
  1379.   }
  1380.   if (args) {
  1381.     OOGLError(1,"%s: internal argument list excess\n\
  1382. Please report this error!", name);
  1383.     goto bad;
  1384.   }
  1385.   return LASSIGN_GOOD;
  1386.  bad:
  1387.   va_end(a_list);
  1388.   return LASSIGN_BAD;
  1389. }
  1390.  
  1391. int LArgClassValid(LType *type)
  1392. {
  1393.   return (type->magic == LTypeMagic);
  1394. }
  1395.  
  1396. LObject *LEvalFunc(char *name, ...)
  1397. {
  1398.   va_list a_list;
  1399.   int laked = 0;
  1400.   LList *list = NULL;
  1401.   LObject *obj, *val;
  1402.   int i;
  1403.   LType *a;
  1404.   LCell cell;
  1405.  
  1406.   if ( (i=funcindex(name)) != REJECT ) {
  1407.     list = LListAppend(list, LNew( LFUNC, &i ));
  1408.   } else {
  1409.     char *copy = strdup(name);
  1410.     list = LListAppend(list, LNew( LSTRING, © ));
  1411.   }
  1412.  
  1413.   va_start(a_list, name);
  1414.   while ( (a=va_arg(a_list, LType *)) != LEND ) {
  1415.     if (a==LHOLD
  1416.     || a==LLITERAL
  1417.     || a==LOPTIONAL
  1418.     ) {
  1419.       /* do nothing */
  1420.     } else if (a==LLAKE) {
  1421.       laked=1;
  1422.     } else if (a==LARRAY) {
  1423.       LType *basetype=va_arg(a_list, LType *);
  1424.       void *array = va_arg(a_list, void *);
  1425.       int count = abs(va_arg(a_list, int));
  1426.       list = LListAppend(list, LMakeArray(basetype, array, count));
  1427.     } else {
  1428.       LPULL(a)(&a_list, &cell);
  1429.       list = LListAppend(list, LTOOBJ(a)(&cell));
  1430.     }
  1431.   }
  1432.   obj = LNew( LLIST, &list );
  1433.   val = LEval(obj);
  1434.   LFree(obj);
  1435.   return val;
  1436. }
  1437.  
  1438. static int filterfromobj(obj, x)
  1439.     LObject *obj;
  1440.     LFilter * *x;
  1441. {
  1442.   if (obj->type != LFILTER) return 0;
  1443.   *x = LFILTERVAL(obj);
  1444.   return 1;
  1445. }
  1446.  
  1447. static LObject *filter2obj(x)
  1448.     LFilter * *x;
  1449. {
  1450.   LFilter *copy = OOGLNew(LFilter);
  1451.   copy->flag = (*x)->flag;
  1452.   copy->value = (*x)->value ? LCopy((*x)->value) : NULL;
  1453.   return LNew( LFILTER, © );
  1454. }
  1455.  
  1456. static void filterfree(x)
  1457.     LFilter * *x;
  1458. {
  1459.   if (*x) {
  1460.     if ((*x)->value) LFree((*x)->value);
  1461.     OOGLFree(*x);
  1462.   }
  1463. }
  1464.  
  1465. static void filterwrite(fp, x)
  1466.     FILE *fp;
  1467.     LFilter * *x;
  1468. {
  1469.   switch ((*x)->flag) {
  1470.   case VAL:
  1471.     fprintf(fp, "filter[VAL,");
  1472.     LWrite(fp, (*x)->value);
  1473.     fprintf(fp, "]");
  1474.     break;
  1475.   case ANY:
  1476.     fprintf(fp, "filter[ANY]");
  1477.     break;
  1478.   case NIL:
  1479.     fprintf(fp, "filter[NIL]");
  1480.     break;
  1481.   default:
  1482.     fprintf(fp, "filter[???");
  1483.     break;
  1484.   }
  1485. }
  1486.  
  1487. LType LFilterp = {
  1488.   "filter",
  1489.   sizeof(LFilter *),
  1490.   filterfromobj,
  1491.   filter2obj,
  1492.   filterfree,
  1493.   filterwrite,
  1494.   NULL,
  1495.   NULL,
  1496.   LSexpr,
  1497.   LTypeMagic
  1498.   };
  1499.  
  1500. LDEFINE(interest, LVOID,
  1501.      "(interest (COMMAND [args]))\n\
  1502. \n\
  1503.     Allows you to express interest in a command.  When geomview\n\
  1504.     executes that command in the future it will echo it to the\n\
  1505.     communication pool from which the interest command came.\n\
  1506.     COMMAND can be any command.  Args specify restrictions on the\n\
  1507.     values of the arguments; if args are present in the interest\n\
  1508.     command, geomview will only echo calls to the command in which\n\
  1509.     the arguments match those given in the interest command.  Two\n\
  1510.     special argument values may appear in the argument list.  \"*\"\n\
  1511.     matches any value. \"nil\" matches any value but supresses the\n\
  1512.     reporting of that value; its value is reported as \"nil\".\n\
  1513. \n\
  1514.     The purpose of the interest command is to allow external\n\
  1515.     modules to find out about things happening inside geomview.\n\
  1516.     For example, a module interested in knowing when a geom called\n\
  1517.     \"foo\" is deleted could say \"(interest (delete foo))\" and would\n\
  1518.     receive the string \"(delete foo)\" when foo is deleted.\n\
  1519. \n\
  1520.     Picking is a special case of this.  For most modules\n\
  1521.     interested in pick events the command \"(interest (pick\n\
  1522.     world))\" is sufficient.  This causes geomview to send a string\n\
  1523.     of the form \"(pick world ...)\" every time a pick event (right\n\
  1524.     mouse double click).  See the \"pick\" command for details.")
  1525. {
  1526.   Lake *calhoun;
  1527.   LList *call;
  1528.  
  1529.   LDECLARE(("interest", LBEGIN,
  1530.         LLAKE, &calhoun,
  1531.         LLITERAL, LLIST, &call,
  1532.         LEND));
  1533.  
  1534.   return do_interest(calhoun, call, "interest");
  1535. }
  1536.  
  1537. LDEFINE(uninterest, LVOID,
  1538.        "(uninterest (COMMAND [args]))\n\
  1539.     Undoes the effect of an \"interest\" command.  (COMMAND [args]) must\n\
  1540.     be identical to those used in the \"interest\" command.")
  1541. {
  1542.   Lake *calhoun;
  1543.   LList *call;
  1544.  
  1545.   LDECLARE(("uninterest", LBEGIN,
  1546.         LLAKE, &calhoun,
  1547.         LLITERAL, LLIST, &call,
  1548.         LEND));
  1549.  
  1550.   return do_interest(calhoun, call, "uninterest");
  1551. }
  1552.  
  1553. LDEFINE(time_interests, LVOID,
  1554.     "(time-interests deltatime initial prefix [suffix])\n\
  1555.     Indicates that all interest-related messages, when separated by at\n\
  1556.     least \"deltatime\" seconds of real time, should be preceded by\n\
  1557.     the string ``prefix'' and followed by ``suffix''; the first message\n\
  1558.     is preceded by ``initial''.  All three are printf format strings,\n\
  1559.     whose argument is the current clock time (in seconds) on that stream.\n\
  1560.     A \"deltatime\" of zero timestamps every message.  Typical usage:\n\
  1561.     (time-interests .1 \"(set-clock %g)\" \"(sleep-until %g)\")  or\n\
  1562.     (time-interests .1 \"(set-clock %g)\"\n\
  1563.         \"(sleep-until %g) (progn (set-clock %g)\" \")\")    or\n\
  1564.     (time-interests .1 \"(set-clock %g)\"\n\
  1565.                \"(if (> 0 (sleep-until %g)) (\" \"))\".")
  1566. {
  1567.   Lake *l;
  1568.   float dt;
  1569.   char *initial = NULL, *prefix = NULL, *suffix = NULL;
  1570.   LDECLARE(("time-interests", LBEGIN,
  1571.     LLAKE, &l,
  1572.     LOPTIONAL, LFLOAT, &dt,
  1573.     LSTRING, &initial,
  1574.     LSTRING, &prefix,
  1575.     LSTRING, &suffix,
  1576.     LEND));
  1577.   if(l->timing_interests) {
  1578.     l->timing_interests = 0;
  1579.     if(l->initial) free(l->initial);
  1580.     if(l->prefix) free(l->prefix);
  1581.     if(l->suffix) free(l->suffix);
  1582.   }
  1583.   if(initial) {
  1584.     l->timing_interests = 1;
  1585.     l->initial = strdup(initial);
  1586.     l->prefix = prefix ? strdup(prefix) : NULL;
  1587.     l->suffix = suffix ? strdup(suffix) : NULL;
  1588.     l->deltatime = dt;
  1589.     l->nexttime = -1e10;
  1590.   }
  1591.   return Lt;
  1592. }
  1593.  
  1594. static LObject *do_interest(Lake *lake, LList *call, char *action)
  1595. {
  1596.   int i;
  1597.   LList *filter, *cargs;
  1598.   char *command;
  1599.   LInterest *new;
  1600.  
  1601.   if (!call || !call->car) {
  1602.     fprintf(stderr,"%s: COMMAND required.\n", action);
  1603.     return Lnil;
  1604.   }
  1605.   if (call->car->type != LSTRING) {
  1606.     fprintf(stderr, "%s: COMMAND must be a string (got %s)\n",
  1607.         action, LSummarize(call->car));
  1608.     return Lnil;
  1609.   }
  1610.   command = LSTRINGVAL(call->car);
  1611.  
  1612.   /* any remaining args are the command's args */
  1613.   cargs = call->cdr;
  1614.  
  1615.   if ( (i=funcindex(command)) < 0 ) {
  1616.     fprintf(stderr, "%s: no such command \"%s\"\n", action,command);
  1617.     return Lnil;
  1618.   }
  1619.  
  1620.   filter = FilterList(cargs);
  1621.  
  1622.   if (strcmp(action, "interest")==0) {
  1623.     new = NewInterest();
  1624.     new->lake = lake;
  1625.     new->filter = filter;
  1626.     AppendInterest(&(functable[i].interested),  new);
  1627.   } else {
  1628.     RemoveInterests(&(functable[i].interested), lake, 1, filter);
  1629.     LListFree(filter);
  1630.   }
  1631.   return Lt;
  1632. }
  1633.  
  1634. static void RemoveInterests(LInterest **interest, Lake *lake,
  1635.                 int usefilter, LList *filter)
  1636. {
  1637.   LInterest *rest;
  1638.  
  1639.   while (*interest) {
  1640.     if (InterestMatch(*interest, lake, usefilter, filter)) {
  1641.       rest = (*interest)->next;
  1642.       DeleteInterest(*interest);
  1643.       *interest = rest;
  1644.     } else {
  1645.       interest = &((*interest)->next);
  1646.     }
  1647.   }
  1648. }
  1649.  
  1650. void RemoveLakeInterests(Lake *lake)
  1651. {
  1652.   int i;
  1653.  
  1654.   for (i=0; i<VVCOUNT(funcvvec); ++i) {
  1655.     if (functable[i].interested)
  1656.       RemoveInterests(&(functable[i].interested), lake, 0, NULL);
  1657.   }
  1658. }
  1659.  
  1660.  
  1661. static int InterestMatch(LInterest *interest, Lake *lake,
  1662.              int usefilter, LList *filter)
  1663. {
  1664.   LList *ifilter;
  1665.  
  1666.   if (interest->lake != lake) return 0;
  1667.   if (!usefilter) return 1;
  1668.   ifilter = interest->filter;
  1669.   while (filter) {
  1670.     if (!ifilter) return 0;
  1671.     if (!FilterMatch(LFILTERVAL(filter->car),
  1672.              LFILTERVAL(ifilter->car))) return 0;
  1673.     filter = filter->cdr;
  1674.     ifilter = ifilter->cdr;
  1675.   }
  1676.   if (ifilter) return 0;
  1677.   return 1;
  1678. }
  1679.  
  1680. static int FilterMatch(LFilter *f1, LFilter *f2)
  1681. {
  1682.   if (f1 && !f2) return 0;
  1683.   if (f2 && !f1) return 0;
  1684.   if (!f1 && !f2) return 1;
  1685.   if (f1->flag != f2->flag) return 0;
  1686.   switch (f1->flag) {
  1687.   case ANY:
  1688.   case NIL:
  1689.     return 1;
  1690.   case VAL:
  1691.     if (f1->value->type != f2->value->type) return 0;
  1692.     return LMATCH(f1->value->type)( &(f1->value->cell), &(f2->value->cell) );
  1693.   default:
  1694.     OOGLError(0,"invalid filter flag value.  Please report this.");
  1695.     return 0;
  1696.   }
  1697. }
  1698.  
  1699. static void DeleteInterest(LInterest *interest)
  1700. {
  1701.   if (interest) {
  1702.     if (interest->filter) LListFree(interest->filter);
  1703.     OOGLFree(interest);
  1704.   }
  1705. }
  1706.  
  1707. static LInterest *NewInterest()
  1708. {
  1709.   LInterest *new = OOGLNewE(LInterest, "interest");
  1710.   new->filter = NULL;
  1711.   new->next = NULL;
  1712.   return new;
  1713. }
  1714.  
  1715. static void AppendInterest(LInterest **head, LInterest *new)
  1716. {
  1717.   if (!head) {
  1718.     OOGLError(0,"Null head pointer in AppendInterest");
  1719.     return;
  1720.   }
  1721.   while (*head) head = &((*head)->next);
  1722.   *head = new;
  1723. }
  1724.  
  1725. static LList *FilterList(LList *args)
  1726. {
  1727.   LList *filterlist;
  1728.   LFilter *filter;
  1729.  
  1730.   if (!args) return NULL;
  1731.   filterlist = NULL;
  1732.   while (args) {
  1733.     if (!args->car) {
  1734.       OOGLError(1,"FilterList internal error");
  1735.       return NULL;
  1736.     }
  1737.     if (   (strcmp(LSTRINGVAL(args->car),"*")==0)
  1738.     || (args->car==Lt) ) {
  1739.       filterlist = LListAppend(filterlist, LRefIncr(LFAny));
  1740.     } else if (   (strcmp(LSTRINGVAL(args->car),"nil")==0)
  1741.            || (args->car==Lnil) ) {
  1742.       filterlist = LListAppend(filterlist, LRefIncr(LFNil));
  1743.     } else {
  1744.       filter = OOGLNew(LFilter);
  1745.       filter->flag = VAL;
  1746.       filter->value = LRefIncr(args->car);
  1747.       filterlist = LListAppend(filterlist, LNew(LFILTER, &filter));
  1748.     }
  1749.     args = args->cdr;
  1750.   }
  1751.   return filterlist;
  1752. }
  1753.  
  1754. static int FilterArgMatch(LList *filter,  LList *args)
  1755. {
  1756.   int filterflag;
  1757.   LObject *filterobj;
  1758.   LCell filterval, argval;
  1759.  
  1760.   while (args) {
  1761.  
  1762.     if (filter) {
  1763.       filterflag = LFILTERVAL(filter->car)->flag;
  1764.       filterobj = LFILTERVAL(filter->car)->value;
  1765.       filter=filter->cdr;
  1766.     } else
  1767.       filterflag = ANY;
  1768.  
  1769.     switch (filterflag) {
  1770.     case VAL:
  1771.       LFROMOBJ(args->car->type)(args->car, &argval);
  1772.       LFROMOBJ(args->car->type)(filterobj, &filterval);
  1773.       if (! LMATCH(args->car->type)(&filterval, &argval))
  1774.     return 0;
  1775.       break;
  1776.     case ANY:
  1777.     case NIL:
  1778.       break;
  1779.     }
  1780.  
  1781.     args = args->cdr;
  1782.   }
  1783.   return 1;
  1784. }
  1785.  
  1786. static void InterestOutput(char *name, LList *args, LInterest *interest)
  1787. {
  1788.   Lake *lake = interest->lake;
  1789.   FILE *outf = lake->streamout;
  1790.   LList *filter = interest->filter;
  1791.   char *suffix = NULL;
  1792.   int filterflag;
  1793.   float now;
  1794.  
  1795.   if (!outf) return;
  1796.  
  1797.   if(lake->timing_interests &&
  1798.         (now = PoolTimeAt(POOL(lake), NULL)) > lake->nexttime) {
  1799.     if(lake->initial) {
  1800.     fprintf(outf, lake->initial, now,now,now);
  1801.     free(lake->initial);
  1802.     lake->initial = NULL;
  1803.     }
  1804.     if(lake->prefix)
  1805.     fprintf(outf, lake->prefix, now,now,now);
  1806.     suffix = lake->suffix;
  1807.   }
  1808.  
  1809.   fprintf(outf, "(%s", name);
  1810.  
  1811.   /* first remove any hidden lake arg */
  1812.   if (args && args->car && args->car->type == LLAKE)
  1813.     args = args->cdr;
  1814.  
  1815.   while (args) {
  1816.  
  1817.     if (filter) {
  1818.       filterflag = LFILTERVAL(filter->car)->flag;
  1819.       filter=filter->cdr;
  1820.     } else
  1821.       filterflag = ANY;
  1822.  
  1823.     switch (filterflag) {
  1824.     case VAL:
  1825.     case ANY:
  1826.       fputc(' ', outf);
  1827.       LWrite(outf, args->car);
  1828.       break;
  1829.     case NIL:
  1830.       fprintf(outf, " nil");
  1831.       break;
  1832.     }
  1833.  
  1834.     args = args->cdr;
  1835.   }
  1836.   fprintf(outf, ")\n");
  1837.   if(suffix)
  1838.     fprintf(outf, suffix, now,now,now);
  1839.   fflush(outf);
  1840. }
  1841.  
  1842. LDEFINE(regtable, LVOID,
  1843.        "(regtable) --- shows the registry table")
  1844. {
  1845.   int i;
  1846.   Lake *outlake;
  1847.   FILE *outf;
  1848.   LInterest *interest;
  1849.   LDECLARE(("regtable", LBEGIN,
  1850.         LLAKE, &outlake,
  1851.         LEND));
  1852.   outf = outlake->streamout;
  1853.  
  1854.   for (i=0; i<VVCOUNT(funcvvec); ++i) {
  1855.     if ((interest = functable[i].interested) != NULL) {
  1856.       fprintf(outf, "%s:\n", functable[i].name);
  1857.       fflush(outf);
  1858.       while (interest) {
  1859.     fprintf(outf, "\t");
  1860.     LListWrite(outf, interest->filter);
  1861.     fprintf(outf, "\n");
  1862.     fflush(outf);
  1863.     interest = interest->next;
  1864.       }
  1865.       fprintf(outf, "\n");
  1866.     }
  1867.   }
  1868.   return Lt;
  1869. }
  1870.  
  1871.  
  1872. static void compile(char *str, register pattern *p)
  1873. {
  1874.     int n;
  1875.     char *rest, *tail;
  1876.  
  1877.     strncpy(p->p0, str, MAXPATLEN-1);
  1878.     p->p0[MAXPATLEN-1] = '\0';
  1879.     for(rest = p->p0, n = 0; (tail = strchr(rest, '*')) && n < MAXPAT; n++) {
  1880.     p->pat[n] = rest;
  1881.     p->len[n] = tail-rest;
  1882.     *tail = '\0';
  1883.     rest = tail+1;
  1884.     }
  1885.     p->pat[n] = rest;
  1886.     p->len[n] = strlen(rest);
  1887.     p->n = n;
  1888. }
  1889.  
  1890. static int match(char *str, register pattern *p)
  1891. {
  1892.     int i;
  1893.     char *rest;
  1894.     if(strncmp(str, p->pat[0], p->len[0])) return 0;    /* Failed */
  1895.     rest = str + p->len[0];
  1896.     for(i = 1; i <= p->n; i++) {
  1897.     if(p->len[i]) {
  1898.         if((rest = strstr(rest, p->pat[i])) == NULL) break;
  1899.         rest += p->len[i];
  1900.     }
  1901.     }
  1902.     return i > p->n && rest && (p->len[p->n] == 0 || *rest == '\0') ? 1 : 0;
  1903. }
  1904.  
  1905. void LHelpDef(char *key, char *message)
  1906. {
  1907.   Help **h = &helps;
  1908.   Help *new = OOGLNew(Help);
  1909.  
  1910.   /* insertion sort... */
  1911.   while (*h && (*h)->key && (strcmp(key,(*h)->key)>0))
  1912.     h = &((*h)->next);
  1913.   new->key = key;
  1914.   new->message = message;
  1915.   new->next = *h;
  1916.   *h = new;
  1917. }
  1918.  
  1919. LDEFINE(help, LVOID,
  1920.        "(help        [command])\n\
  1921.     Command may include \"*\"s as wildcards; see also \"??\"\n\
  1922.     One-line command help; lists names only if multiple commands match.")
  1923. {
  1924.   char *pat = "*";
  1925.   char *nl;
  1926.   pattern p;
  1927.   int seen = 0;
  1928.   Help *h, *last = NULL;
  1929.   Lake *brownie;
  1930.   FILE *outf;
  1931.  
  1932.   LDECLARE(("help", LBEGIN,
  1933.         LLAKE, &brownie,
  1934.         LOPTIONAL,
  1935.         LSTRING, &pat,
  1936.         LEND));
  1937.   if((outf = brownie->streamout) == NULL) outf = stdout;
  1938.   compile(pat, &p);
  1939.   for(h=helps; h!=NULL; h=h->next) {
  1940.     if(match(h->key, &p)) {
  1941.     if(++seen >= 2) {
  1942.         if(seen == 2) fprintf(outf,"%-15s ", last->key);
  1943.         fprintf(outf, seen%4 ? "%-15s " : "%s\n", h->key);
  1944.     }
  1945.     last = h;
  1946.     }
  1947.   }
  1948.   switch(seen) {
  1949.   default: if(seen%4) fprintf(outf, "\n"); break;
  1950.   case 0: fprintf(outf, nomatch, pat); break;
  1951.   case 1:
  1952.     nl = strchr(last->message, '\n');
  1953.     fprintf(outf, "%.*s\n", nl && last->message[0]=='('
  1954.             ? nl - last->message  : 9999,  last->message);
  1955.     break;
  1956.   }
  1957.   fflush(outf);
  1958.   return Lt;
  1959. }
  1960.  
  1961. LDEFINE(morehelp, LVOID,
  1962.     "(morehelp    command)  \"command\" may include \"*\" wildcards\n\
  1963.     Prints more info than \"(help command)\"")
  1964. {
  1965.   char *pat;
  1966.   pattern p;
  1967.   int seen = 0;
  1968.   Help *h;
  1969.   Lake *cedar;
  1970.   FILE *outf;
  1971.  
  1972.   LDECLARE(("morehelp", LBEGIN,
  1973.         LLAKE, &cedar,
  1974.         LSTRING, &pat,
  1975.         LEND));
  1976.   if((outf = cedar->streamout) == NULL) outf = stdout;
  1977.   compile(pat, &p);
  1978.   for(h=helps; h!=NULL; h=h->next) {
  1979.     if(match(h->key, &p)) {
  1980.     fprintf(outf, "%s\n", h->message);
  1981.     seen++;
  1982.     }
  1983.   }
  1984.  
  1985.   if(seen==0) fprintf(outf, nomatch, pat);
  1986.   fflush(outf);
  1987.   return Lt;
  1988. }
  1989.  
  1990. LInterest *LInterestList(char *funcname)
  1991. {
  1992.   int index = funcindex(funcname);
  1993.   if (index == REJECT) return NULL;
  1994.   return functable[index].interested;
  1995. }
  1996.  
  1997. char *LakeName(Lake *lake)
  1998. {
  1999.   return lake ? PoolName(lake->river) : NULL;
  2000. }
  2001.  
  2002. char *LSummarize(LObject *obj)
  2003. {
  2004.   char buf[8192];
  2005.   FILE *f = fstropen(buf, 8192, "w");
  2006.   static char *summary;
  2007.  
  2008.   LWrite(f, obj);
  2009.   fputc('\0', f);
  2010.   fclose(f);
  2011.   buf[8191] = '\0';
  2012.   if(strlen(buf) > 80) strcpy(buf+75, " ...");
  2013.   if(summary) free(summary);
  2014.   return summary = strdup(buf);
  2015. }
  2016.