1 /* Copyright (C) 1992-1998 The Geometry Center
2  * Copyright (C) 1998-2000 Stuart Levy, Tamara Munzner, Mark Phillips
3  * Copyright (C) 2006-2007 Claus-Justus Heine
4  *
5  * This file is part of Geomview.
6  *
7  * Geomview is free software; you can redistribute it and/or modify it
8  * under the terms of the GNU Lesser General Public License as published
9  * by the Free Software Foundation; either version 2, or (at your option)
10  * any later version.
11  *
12  * Geomview is distributed in the hope that it will be useful, but
13  * WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15  * Lesser General Public License for more details.
16  *
17  * You should have received a copy of the GNU Lesser General Public
18  * License along with Geomview; see the file COPYING.  If not, write
19  * to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139,
20  * USA, or visit http://www.gnu.org.
21  */
22 
23 #if 0
24 static char copyright[] = "Copyright (C) 1992-1998 The Geometry Center\n\
25 Copyright (C) 1998-2000 Stuart Levy, Tamara Munzner, Mark Phillips";
26 #endif
27 
28 #ifdef HAVE_CONFIG_H
29 # include "config.h"
30 #endif
31 
32 /* Authors: Stuart Levy, Tamara Munzner, Mark Phillips */
33 
34 /*
35  * lisp.c: minimal (but less minimal than before) lisp interpreter
36  */
37 
38 #include <stdio.h>
39 #include <string.h>
40 #include <math.h>
41 #include <stdlib.h>
42 #include <ctype.h>
43 #include "lisp.h"
44 #include "clisp.c"
45 #include "freelist.h"
46 
47 #define MAXPAT 10
48 #define MAXPATLEN 128
49 
50 typedef struct _pattern {
51   int n;
52   char p0[MAXPATLEN];
53   char *pat[MAXPAT];
54   int len[MAXPAT];
55 } pattern;
56 
57 static bool match(const char *str, pattern *p);
58 static void compile(const char *str, pattern *p);
59 static int LCompare(const char *name, LObject *expr1, LObject *expr2);
60 
61 typedef struct Help {
62   const char *key;
63   const char *message;
64   struct Help *next;
65 } Help;
66 
67 static Help *helps = NULL;
68 
69 static char nomatch[] = "No commands match \"%s\"; see \"(? *)\" for a list.\n";
70 
71 static bool FilterArgMatch(LList *filter, LList *args);
72 static void InterestOutput(char *name, LList *args, LInterest *interest);
73 
74 static LFilter FAny = {ANY, NULL};
75 static LFilter FNil = {NIL, NULL};
76 static LObject LFAny[1] = {{ LFILTER, 1, { &FAny } }};
77 static LObject LFNil[1] = {{ LFILTER, 1, { &FNil } }};
78 
79 
80 static bool obj2array(LObject *obj,
81 		      LType *type, char *x, int *n, bool hold);
82 static bool obj2vararray(LObject *obj,
83 			 LType *type, char **x, int *n, bool hold);
84 LObject *LMakeArray(LType *basetype, char *array, int count);
85 
86 /* Use -1 as the item size of special type markers
87  * for quick detection in LParseArgs()/AssignArgs().
88  */
89 LType Larray = { NULL, -1, };
90 LType Lvararray = { NULL, -1, };
91 LType Lend = { NULL, -1, };
92 LType Lrest = { NULL, -1, };
93 LType Lhold = { NULL, -1, };
94 LType Lliteral = { NULL, -1, };
95 LType Loptional = { NULL, -1, };
96 
97 #define REJECT -1
98 
99 typedef struct {
100   LObjectFunc fptr;
101   LObject *lambda; /* != NULL for non-builtins */
102   char *name;
103   char *help;
104   LInterest *interested;
105 } LFunction;
106 
107 extern LType LFuncp;
108 #define LFUNC (&LFuncp)
109 #define LFUNCVAL(obj) ((int)((obj)->cell.i))
110 
111 vvec funcvvec;
112 #define functable VVEC(funcvvec,LFunction)
113 
114 static Fsa func_fsa;
115 
116 /* lambda expression parameters */
117 typedef struct LNameSpace LNameSpace;
118 struct LNameSpace
119 {
120   vvec       table;
121   Fsa        parser;
122   LNameSpace *next;
123 };
124 
125 static LNameSpace *lambda_namespace;
126 
127 /* we also support a global variable name-space, accessible via
128  *
129  * (setq ...)
130  *
131  * Note that (setq symbol value) does not mean that you can bind,
132  * e.g. geometries to a lisp variable: the return value of (geometry
133  * BLAH) will just be Lt in the case of success, or Lnil in the case
134  * of error. So: (setq foo (geometry blah)) will just bind foo the Lt
135  * or Lnil.
136  */
137 static LNameSpace setq_namespace[1];
138 
139 /*
140  * function prototypes
141  */
142 
143 static LParseResult AssignArgs(const char *name, LList *args, va_list a_list);
144 static int funcindex(const char *name);
145 
146 static inline LObject *LSexpr0(Lake *lake, int listhow);
147 
148 #define	LIST_LITERAL	0
149 #define	LIST_FUNCTION	1
150 #define	LIST_EVAL	2	/* Parse with intention to evaluate */
151 
152 LObject *Linterest(Lake *lake, LList *args);
153 LObject *Luninterest(Lake *lake, LList *args);
154 LObject *Lregtable(Lake *lake, LList *args);
155 static LObject *do_interest(Lake *lake, LList *call, char *action);
156 
157 static void RemoveInterests(LInterest **interest, Lake *lake,
158 			    int usefilter, LList *filter);
159 static bool InterestMatch(LInterest *interest, Lake *lake,
160 			  bool usefilter, LList *filter);
161 static bool FilterMatch(LFilter *f1, LFilter *f2);
162 static void DeleteInterest(LInterest *interest);
163 static LInterest *NewInterest();
164 static void AppendInterest(LInterest **head, LInterest *new);
165 static LList *FilterList(LList *args);
166 static inline bool lambdafromobj(LObject *lambda, LList **args, LList **body);
167 static inline bool
168 namespace_put(LNameSpace *ns, char *name, LObject *value, bool overwrite);
169 static inline LObject *namespace_get(LNameSpace *ns, char *name);
170 static inline LObject *ParseArg(LType *type, Lake *lake);
171 
172 /*
173  * nil object implementation
174  */
175 
176 static LObject nil = {LLIST, 1, { NULL } };
177 LObject *Lnil = &nil;
178 
179 /*
180  * t object implementation
181  */
182 
twrite(FILE * fp,void * value)183 static void twrite(FILE *fp, void *value)
184 {
185   (void)value;
186   fprintf(fp,"t");
187 }
188 
189 static LType ttype = {
190   "t",
191   sizeof(int),
192   NULL,
193   NULL,
194   NULL,
195   twrite,
196   NULL,
197   NULL,
198   NULL,
199   LTypeMagic
200 } ;
201 static LObject t  = {&ttype, 1, { NULL } };
202 LObject *Lt = &t;
203 
204 /*
205  * int object implementation
206  */
207 
intfromobj(LObject * obj,int * x)208 static bool intfromobj(LObject *obj, int *x)
209 {
210   if (obj->type == LSTRING || obj->type == LSYMBOL) {
211     char *cp = LSTRINGVAL(obj);
212     char *end;
213     long value;
214     double dval;
215 
216     if (strcmp(cp, "nil") == 0) {
217       *x = 0;
218       return true;
219     }
220 
221     *x = value = strtol(cp, &end, 0);
222     if (((size_t)end - (size_t)cp) == strlen(cp)) {
223       return (long)(int)value == value;
224     }
225     *x = dval = strtod(cp, &end);
226     if (((size_t)end - (size_t)cp) == strlen(cp)) {
227       return (double)*x == dval;
228     }
229     return false;
230   } else if (obj->type == LINT) {
231     *x = LINTVAL(obj);
232   } else if (obj->type == LLONG) {
233     long val = LLONGVAL(obj);
234     *x = (int)val;
235     return (long)(int)val == val;
236   } else if (obj == Lnil) {
237     *x = 0;
238   } else if (obj->type == LFLOAT) {
239     float val = LFLOATVAL(obj);
240     *x = (int)val;
241     return (float)(int)val == val;
242   } else if (obj->type == LDOUBLE) {
243     double val = LDOUBLEVAL(obj);
244     *x = (int)val;
245     return (double)(int)val == val;
246   } else {
247     return false;
248   }
249   return true;
250 }
251 
int2obj(int * x)252 static LObject *int2obj(int *x)
253 {
254   return LNew( LINT, x );
255 }
256 
intfree(int * x)257 static void intfree(int *x)
258 {
259   (void)x;
260 }
261 
intmatch(int * a,int * b)262 static bool intmatch(int *a, int *b)
263 {
264   return *a == *b;
265 }
266 
intwrite(FILE * fp,int * x)267 static void intwrite(FILE *fp, int *x)
268 {
269   fprintf(fp, "%1d", *x);
270 }
271 
intpull(va_list * a_list,int * x)272 static void intpull(va_list *a_list, int *x)
273 {
274   *x = va_arg(*a_list, int);
275 }
276 
intparse(Lake * lake)277 static LObject *intparse(Lake *lake)
278 {
279   /* parse the next thing from the lake */
280   LObject *obj = LSexpr(lake);
281 
282   /* if it's a string, promote it to an int, otherwise
283      leave it as it is */
284   if (obj->type == LSTRING || obj->type == LSYMBOL) {
285     char *cp = LSTRINGVAL(obj);
286     char *end;
287     int val;
288 
289     if (strcmp(cp, "nil") == 0) {
290       val = 0;
291       end = cp + 3;
292     } else {
293       val = strtol(cp, &end, 0);
294     }
295     if (((size_t)end - (size_t)cp) == strlen(cp)) {
296       free(LSTRINGVAL(obj));
297       obj->type = LINT;
298       obj->cell.i = val;
299     }
300   }
301   return obj;
302 }
303 
304 LType LIntp = {
305   "int",
306   sizeof(int),
307   intfromobj,
308   int2obj,
309   intfree,
310   intwrite,
311   intmatch,
312   intpull,
313   intparse,
314   LTypeMagic
315 };
316 
317 /*
318  * long object implementation
319  */
320 
longfromobj(LObject * obj,long * x)321 static bool longfromobj(LObject *obj, long *x)
322 {
323   if (obj->type == LSTRING || obj->type == LSYMBOL) {
324     char *cp = LSTRINGVAL(obj);
325     char *end;
326     double dval;
327 
328     if (strcmp(cp, "nil") == 0) {
329       *x = 0;
330       return true;
331     }
332 
333     *x = strtol(cp, &end, 0);
334     if (((size_t)end - (size_t)cp) == strlen(cp)) {
335       return true;
336     }
337     *x = dval = strtod(cp, &end);
338     if (((size_t)end - (size_t)cp) == strlen(cp)) {
339       return (double)*x == dval;
340     }
341     return false;
342   } else if (obj->type == LLONG) {
343     *x = LLONGVAL(obj);
344   } else if (obj->type == LINT) {
345     *x = LINTVAL(obj);
346   } else if (obj == Lnil) {
347     *x = 0;
348   } else if (obj->type == LFLOAT) {
349     float val = LFLOATVAL(obj);
350     *x = (long)val;
351     return (float)(long)val == val;
352   } else if (obj->type == LDOUBLE) {
353     double val = LDOUBLEVAL(obj);
354     *x = (long)val;
355     return (double)(long)val == val;
356   } else {
357     return false;
358   }
359   return true;
360 }
361 
long2obj(long * x)362 static LObject *long2obj(long *x)
363 {
364   return LNew( LLONG, x );
365 }
366 
longfree(long * x)367 static void longfree(long *x)
368 {
369   (void)x;
370 }
371 
longmatch(long * a,long * b)372 static bool longmatch(long *a, long *b)
373 {
374   return *a == *b;
375 }
376 
longwrite(FILE * fp,long * x)377 static void longwrite(FILE *fp, long *x)
378 {
379   fprintf(fp, "%1lu", *x);
380 }
381 
longpull(va_list * a_list,long * x)382 static void longpull(va_list *a_list, long *x)
383 {
384   *x = va_arg(*a_list, long);
385 }
386 
longparse(Lake * lake)387 static LObject *longparse(Lake *lake)
388 {
389   /* parse the next thing from the lake */
390   LObject *obj = LSexpr(lake);
391 
392   /* if it's a string, promote it to a long, otherwise
393      leave it as it is */
394   if (obj->type == LSTRING || obj->type == LSYMBOL) {
395     char *cp = LSTRINGVAL(obj);
396     char *end;
397     long val;
398 
399     if (strcmp(cp, "nil") == 0) {
400       val = 0;
401       end = cp + 3;
402     } else {
403       val = strtol(cp, &end, 0);
404     }
405     if (((size_t)end - (size_t)cp) == strlen(cp)) {
406       free(LSTRINGVAL(obj));
407       obj->type = LLONG;
408       obj->cell.l = val;
409     }
410   }
411   return obj;
412 }
413 
414 LType LLongp = {
415   "long",
416   sizeof(long),
417   longfromobj,
418   long2obj,
419   longfree,
420   longwrite,
421   longmatch,
422   longpull,
423   longparse,
424   LTypeMagic
425 };
426 
427 /*
428  * float object implementation
429  */
430 
floatfromobj(LObject * obj,float * x)431 static bool floatfromobj(LObject *obj, float *x)
432 {
433   if (obj->type == LSTRING || obj->type == LSYMBOL) {
434     char *cp = LSTRINGVAL(obj);
435     char *end;
436 
437     if (strcmp(cp, "nil") == 0) {
438       *x = 0;
439       return true;
440     }
441 
442     *x = strtod(cp, &end);
443     return ((size_t)end - (size_t)cp) == strlen(cp) ? true : false;
444   } else if (obj->type == LFLOAT) {
445     *x = LFLOATVAL(obj);
446   } else if (obj->type == LLONG) {
447     *x = LLONGVAL(obj);
448   } else if (obj->type == LINT) {
449     *x = LINTVAL(obj);
450   } else {
451     return false;
452   }
453   return true;
454 }
455 
float2obj(float * x)456 static LObject *float2obj(float *x)
457 {
458   return LNew( LFLOAT, x );
459 }
460 
floatfree(float * x)461 static void floatfree(float *x)
462 {
463   (void)x;
464 }
465 
floatmatch(float * a,float * b)466 static bool floatmatch(float *a, float *b)
467 {
468   return *a == *b;
469 }
470 
floatwrite(FILE * fp,float * x)471 static void floatwrite(FILE *fp, float *x)
472 {
473   fprintf(fp, "%1g", *x);
474 }
475 
floatpull(va_list * a_list,float * x)476 static void floatpull(va_list *a_list, float *x)
477 {
478   *x = va_arg(*a_list, double);
479 }
480 
floatparse(Lake * lake)481 static LObject *floatparse(Lake *lake)
482 {
483   /* parse the next thing from the lake */
484   LObject *obj = LSexpr(lake);
485 
486   /* if it's a string or another numerical value, promote it to a
487      float, otherwise leave it as it is */
488   if (obj->type == LSTRING || obj->type == LSYMBOL) {
489     char *cp = LSTRINGVAL(obj);
490     char *end;
491     float val = strtod(cp, &end);
492     /* Allow a conversion only if the entire string is a float;
493      * otherwise reject it. There is no point in converting 1.4foobar
494      * to a float.
495      */
496     if (((size_t)end - (size_t)cp) == strlen(cp)) {
497       free(LSTRINGVAL(obj));
498       obj->type = LFLOAT;
499       obj->cell.f = val;
500     }
501   } else if (obj->type == LINT) {
502     obj->type = LFLOAT;
503     obj->cell.f = LINTVAL(obj);
504   } else if (obj->type == LLONG) {
505     obj->type = LFLOAT;
506     obj->cell.f = LLONGVAL(obj);
507   } else if (obj->type == LDOUBLE) {
508     obj->type = LFLOAT;
509     obj->cell.f = LDOUBLEVAL(obj);
510   }
511 
512   return obj;
513 }
514 
515 LType LFloatp = {
516   "float",
517   sizeof(float),
518   floatfromobj,
519   float2obj,
520   floatfree,
521   floatwrite,
522   floatmatch,
523   floatpull,
524   floatparse,
525   LTypeMagic
526 };
527 
528 /*
529  * double object implementation
530  */
531 
doublefromobj(LObject * obj,double * x)532 static bool doublefromobj(LObject *obj, double *x)
533 {
534   if (obj->type == LSTRING || obj->type == LSYMBOL) {
535     char *cp = LSTRINGVAL(obj);
536     char *end;
537 
538     if (strcmp(cp, "nil") == 0) {
539       *x = 0;
540       return true;
541     }
542 
543     *x = strtod(cp, &end);
544     return ((size_t)end - (size_t)cp) == strlen(cp) ? true : false;
545   } else if (obj->type == LDOUBLE) {
546     *x = LDOUBLEVAL(obj);
547   } else if (obj->type == LFLOAT) {
548     *x = LFLOATVAL(obj);
549   } else if (obj->type == LLONG) {
550     *x = LLONGVAL(obj);
551   } else if (obj->type == LINT) {
552     *x = LINTVAL(obj);
553   } else {
554     return false;
555   }
556   return true;
557 }
558 
double2obj(double * x)559 static LObject *double2obj(double *x)
560 {
561   return LNew( LDOUBLE, x );
562 }
563 
doublefree(double * x)564 static void doublefree(double *x)
565 {
566   (void)x;
567 }
568 
doublematch(double * a,double * b)569 static bool doublematch(double *a, double *b)
570 {
571   return *a == *b;
572 }
573 
doublewrite(FILE * fp,double * x)574 static void doublewrite(FILE *fp, double *x)
575 {
576   fprintf(fp, "%1g", *x);
577 }
578 
doublepull(va_list * a_list,double * x)579 static void doublepull(va_list *a_list, double *x)
580 {
581   *x = va_arg(*a_list, double);
582 }
583 
doubleparse(Lake * lake)584 static LObject *doubleparse(Lake *lake)
585 {
586   /* parse the next thing from the lake */
587   LObject *obj = LSexpr(lake);
588 
589   /* if it's a string or another numerical value, promote it to a
590      double, otherwise leave it as it is */
591   if (obj->type == LSTRING || obj->type == LSYMBOL) {
592     char *cp = LSTRINGVAL(obj);
593     char *end;
594     double val = strtod(cp, &end);
595     /* Allow a conversion only if the entire string is a double;
596      * otherwise reject it. There is no point in converting 1.4foobar
597      * to a double.
598      */
599     if (((size_t)end - (size_t)cp) == strlen(cp)) {
600       free(LSTRINGVAL(obj));
601       obj->type = LDOUBLE;
602       obj->cell.d = val;
603     }
604   } else if (obj->type == LINT) {
605     obj->type = LDOUBLE;
606     obj->cell.f = LINTVAL(obj);
607   } else if (obj->type == LLONG) {
608     obj->type = LDOUBLE;
609     obj->cell.f = LLONGVAL(obj);
610   } else if (obj->type == LFLOAT) {
611     obj->type = LDOUBLE;
612     obj->cell.f = LFLOATVAL(obj);
613   }
614   return obj;
615 }
616 
617 LType LDoublep = {
618   "double",
619   sizeof(double),
620   doublefromobj,
621   double2obj,
622   doublefree,
623   doublewrite,
624   doublematch,
625   doublepull,
626   doubleparse,
627   LTypeMagic
628 };
629 
630 /*
631  * string object implementation
632  */
633 
634 
stringfromobj(LObject * obj,char ** x)635 static bool stringfromobj(LObject *obj, char **x)
636 {
637   if (obj->type == LSTRING || obj->type == LSYMBOL) {
638     *x = LSTRINGVAL(obj);
639   } else {
640     return false;
641   }
642   return true;
643 }
644 
string2obj(char ** x)645 static LObject *string2obj(char **x)
646 {
647   char *copy = *x ? strdup(*x) : NULL;
648   return LNew( LSTRING, &copy );
649 }
650 
stringfree(char ** x)651 static void stringfree(char **x)
652 {
653   if (*x) free(*x);
654 }
655 
stringmatch(char ** a,char ** b)656 static bool stringmatch(char **a, char **b)
657 {
658   if (!*a) return *b==NULL;
659   if (!*b) return *a==NULL;
660   return strcmp(*a,*b)==0 ;
661 }
662 
stringwrite(FILE * fp,char ** x)663 static void stringwrite(FILE *fp, char **x)
664 {
665   fprintf(fp, "\"%s\"", *x);
666 }
667 
stringpull(va_list * a_list,char ** x)668 static void stringpull(va_list *a_list, char **x)
669 {
670   *x = va_arg(*a_list, char *);
671 }
672 
stringparse(Lake * lake)673 static LObject *stringparse(Lake *lake)
674 {
675   LObject *obj = LSexpr(lake);
676 
677 #if 0
678   /* Don't otherwise unquoted strings will not be bound to argument
679    * valus; or I would have to edit all LDEFUN() invocations.
680    */
681   if (obj->type == LSYMBOL) {
682     obj->type = LSTRING;
683   }
684 #endif
685   return obj;
686 }
687 
688 LType LStringp = {
689   "string",
690   sizeof(char *),
691   stringfromobj,
692   string2obj,
693   stringfree,
694   stringwrite,
695   stringmatch,
696   stringpull,
697   stringparse,
698   LTypeMagic
699 };
700 
701 /*
702  * Symbol object implementation. We treat symbols and strings
703  * interchangeably, with the exception that symbols can bind to
704  * values, but strings cannot. This makes a difference during the
705  * evaluation of lambda expressions.
706  */
707 
symbolfromobj(LObject * obj,char ** x)708 static bool symbolfromobj(LObject *obj, char **x)
709 {
710   if (obj->type == LSYMBOL) {
711     *x = LSYMBOLVAL(obj);
712   } else {
713     return false;
714   }
715   return true;
716 }
717 
symbol2obj(char ** x)718 static LObject *symbol2obj(char **x)
719 {
720   char *copy = *x ? strdup(*x) : NULL;
721   return LNew(LSYMBOL, &copy);
722 }
723 
symbolwrite(FILE * fp,char ** x)724 static void symbolwrite(FILE *fp, char **x)
725 {
726   fprintf(fp, "%s", *x);
727 }
728 
symbolparse(Lake * lake)729 static LObject *symbolparse(Lake *lake)
730 {
731   LObject *obj = LSexpr(lake);
732 
733   /* Mmmh. Shouldn't it be the otherway round: somebody requesting an
734    * LSYMBOL in the input stream would rather expect to get the symbol
735    * value; so maybe we should promote from LSYMBOL to LSTRING
736    * here. Maybe not. Leave it as is for the moment.
737    */
738   if (obj->type == LSTRING) {
739     obj->type = LSYMBOL;
740   }
741   return obj;
742 }
743 
744 LType LSymbolp = {
745   "symbol",
746   sizeof(char *),
747   symbolfromobj,
748   symbol2obj,
749   stringfree,
750   symbolwrite,
751   stringmatch,
752   stringpull,
753   symbolparse,
754   LTypeMagic
755 };
756 
757 /*
758  * list implementation
759  */
760 static DEF_FREELIST(LList);
761 
LListNew(void)762 LList *LListNew(void)
763 {
764   LList *new;
765 
766   FREELIST_NEW(LList, new);
767   new->cdr = NULL;
768   return new;
769 }
770 
LListCopy(LList * list)771 LList *LListCopy(LList *list)
772 {
773   LList *new;
774 
775   if (!list) {
776     return NULL;
777   }
778   new = LListNew();
779   if (list->car) {
780     new->car = LCopy(list->car);
781   } else {
782     new->car = NULL;
783   }
784   new->cdr = LListCopy(list->cdr);
785   return new;
786 }
787 
LListShallowCopy(LList * list)788 LList *LListShallowCopy(LList *list)
789 {
790   LList *new;
791 
792   if (!list) {
793     return NULL;
794   }
795   new = LListNew();
796   if (list->car) {
797     new->car = LRefIncr(list->car);
798   } else {
799     new->car = NULL;
800   }
801   new->cdr = LListShallowCopy(list->cdr);
802   return new;
803 }
804 
LListFree(LList * list)805 void LListFree(LList *list)
806 {
807   if (!list) {
808     return;
809   }
810   if (list->cdr) {
811     LListFree(list->cdr);
812   }
813   LFree(list->car);
814   FREELIST_FREE(LList, list);
815 }
816 
LListWrite(FILE * fp,LList * list)817 void LListWrite(FILE *fp, LList *list)
818 {
819   int first = 1;
820   if (list == NULL) {
821     fprintf(fp, "nil");
822   } else {
823     fprintf(fp,"(");
824     while (list != NULL) {
825       if (!first) {
826 	fprintf(fp," ");
827       }
828       first = 0;
829       LWrite(fp, list->car);
830       list = list->cdr;
831     }
832     fprintf(fp,")");
833   }
834 }
835 
836 /**********************************************************************/
837 
listfromobj(LObject * obj,LList ** x)838 bool listfromobj(LObject *obj, LList **x)
839 {
840   if (obj->type != LLIST) {
841     return false;
842   }
843   *x = LLISTVAL(obj);
844   return true;
845 }
846 
list2obj(LList ** x)847 LObject *list2obj(LList **x)
848 {
849   LList *list = *x ? LListCopy(*x) : NULL;
850   return LNew( LLIST, &list );
851 }
852 
listfree(LList ** x)853 void listfree(LList **x)
854 {
855   if (*x) {
856     LListFree(*x);
857   }
858 }
859 
listmatch(LList ** a,LList ** b)860 bool listmatch(LList **a, LList **b)
861 {
862   return *a == *b;
863 }
864 
listwrite(FILE * fp,LList ** x)865 void listwrite(FILE *fp, LList **x)
866 {
867   LListWrite(fp, *x);
868 }
869 
listpull(va_list * a_list,LList ** x)870 void listpull(va_list *a_list, LList **x)
871 {
872   *x = va_arg(*a_list, LList *);
873 }
874 
875 LType LListp = {
876   "list",
877   sizeof(LList *),
878   listfromobj,
879   list2obj,
880   listfree,
881   listwrite,
882   listmatch,
883   listpull,
884   LSexpr,
885   LTypeMagic
886 };
887 
objfromobj(LObject * obj,LObject ** x)888 bool objfromobj(LObject *obj, LObject **x)
889 {
890   *x = obj;
891   return true;
892 }
893 
obj2obj(LObject ** x)894 LObject *obj2obj(LObject **x)
895 {
896   if (*x) LRefIncr(*x);
897   return *x;
898 }
899 
objpull(va_list * a_list,LObject ** x)900 void objpull(va_list *a_list, LObject **x)
901 {
902   *x = va_arg(*a_list, LObject *);
903 }
904 
objmatch(LObject ** a,LObject ** b)905 bool objmatch(LObject **a, LObject **b)
906 {
907   return *a == *b;
908 }
909 
910 LType LObjectp = {
911   "lisp object",
912   sizeof(LObject *),
913   objfromobj,
914   obj2obj,
915   NULL,
916   NULL,
917   objmatch,
918   objpull,
919   LSexpr,
920   LTypeMagic
921 };
922 
923 /*
924  * Lake implementation
925  */
926 
LakeDefine(IOBFILE * streamin,FILE * streamout,void * river)927 Lake *LakeDefine(IOBFILE *streamin, FILE *streamout, void *river)
928 {
929   Lake *lake = OOGLNewE(Lake, "new Lake");
930   lake->streamin = streamin;
931   lake->streamout = streamout ? streamout : stdout;
932   lake->river = river;
933   lake->timing_interests = 0;
934   return lake;
935 }
936 
LakeFree(Lake * lake)937 void LakeFree(Lake *lake)
938 {
939   OOGLFree(lake);
940 }
941 
942 
943 /*
944  * Lake object implementation
945  *   ( Not the same as the Lake itself; the lake object is a lisp
946  *     object type whose value is a Lake pointer. )
947  */
948 
949 
lakefromobj(LObject * obj,Lake ** x)950 static bool lakefromobj(LObject *obj, Lake **x)
951 {
952   if (obj->type == LLAKE) {
953     *x = LLAKEVAL(obj);
954     return true;
955   }
956   return false;
957 }
958 
lake2obj(Lake ** x)959 static LObject *lake2obj(Lake **x)
960 {
961   return LNew( LLAKE, x );
962 }
963 
lakefree(Lake ** x)964 static void lakefree(Lake **x)
965 {
966   (void)x;
967 }
968 
lakewrite(FILE * fp,Lake ** x)969 static void lakewrite(FILE *fp, Lake **x)
970 {
971   (void)x;
972   fprintf(fp,"-lake-");
973 }
974 
975 
976 LType LLakep = {
977   "lake",
978   sizeof(Lake *),
979   lakefromobj,
980   lake2obj,
981   lakefree,
982   lakewrite,
983   NULL,
984   NULL,
985   NULL,
986   LTypeMagic
987 };
988 
989 /*
990  * function object implementation
991  */
992 
funcfromobj(LObject * obj,int * x)993 bool funcfromobj(LObject *obj, int *x)
994 {
995   if (obj->type == LSYMBOL) {
996     *x = funcindex(LSYMBOLVAL(obj));
997     if (*x == REJECT) return false;
998   } else if (obj->type == LFUNC) {
999     *x = LFUNCVAL(obj);
1000   } else if (obj->type == LLIST) {
1001     if (lambdafromobj(obj, NULL, NULL)) {
1002       *x = funcindex("\a\bEvalLambda");
1003     }
1004   } else {
1005     return false;
1006   }
1007   return true;
1008 }
1009 
func2obj(int * x)1010 LObject *func2obj(int *x)
1011 {
1012   return LNew( LFUNC, x );
1013 }
1014 
funcfree(int * x)1015 void funcfree(int *x)
1016 {
1017   (void)x;
1018 }
1019 
funcmatch(int * a,int * b)1020 bool funcmatch(int *a, int *b)
1021 {
1022   return *a == *b;
1023 }
1024 
funcwrite(FILE * fp,int * x)1025 void funcwrite(FILE *fp, int *x)
1026 {
1027   fprintf(fp, "%s", functable[*x].name);
1028 }
1029 
funcpull(va_list * a_list,int * x)1030 void funcpull(va_list *a_list, int *x)
1031 {
1032   *x = va_arg(*a_list, int);
1033 }
1034 
1035 LType LFuncp = {
1036   "lisp function",
1037   sizeof(int),
1038   funcfromobj,
1039   func2obj,
1040   funcfree,
1041   funcwrite,
1042   funcmatch,
1043   funcpull,
1044   LSexpr,
1045   LTypeMagic
1046 };
1047 
FUNCTOOBJ(const char * name)1048 static inline LObject *FUNCTOOBJ(const char *name)
1049 {
1050   int idx = funcindex(name);
1051 
1052   if (idx < 0) {
1053     return Lnil;
1054   }
1055   return func2obj(&idx);
1056 }
1057 
1058 /**********************************************************************/
1059 
LInit()1060 void LInit()
1061 {
1062   /* Function name-space */
1063   VVINIT(funcvvec, LFunction, 256);
1064   func_fsa = fsa_initialize( NULL, (void*)REJECT );
1065 
1066   /* estabilish the global setq name-space */
1067   VVINIT(setq_namespace->table, LObject *, 256);
1068   setq_namespace->parser = fsa_initialize(NULL, (void *)REJECT);
1069   lambda_namespace = setq_namespace;
1070 
1071   {
1072     extern LObject *Lhelp(Lake *lake, LList *args);
1073     extern LObject *Lmorehelp(Lake *lake, LList *args);
1074     LDefun("?", Lhelp,
1075 	   "(?  [command])"
1076 	   "Command may include \"*\"s as wildcards; see also \"??\". "
1077 	   "One-line command help; lists names only if multiple commands match."
1078 	   "? is a synonym for \"help\".");
1079     LDefun("??", Lmorehelp,
1080 	   "(?? command)\n"
1081 	   "\"command\" may include \"*\" wildcards"
1082 	   "Prints more info than \"(? command)\".  ?? is a synonym "
1083 	   "for \"morehelp\".");
1084   }
1085 
1086   clisp_init();
1087 
1088   LHelpDef("STATEMENT",
1089 	   "\nSTATEMENT represents a function call.  Function calls have "
1090 	   "the form \"( func arg1 arg2 ... )\", where func is the name "
1091 	   "of the function and arg1, arg2, ... are the arguments.");
1092 
1093 }
1094 
1095 LDEFINE(quote, LLOBJECT,
1096 	"(quote EXPR)\n"
1097 	"returns the symbolic lisp expression EXPR without evaluating it.")
1098 {
1099   LObject *arg;
1100 
1101   LDECLARE(("quote", LBEGIN,
1102 	    LHOLD, LLOBJECT, &arg,
1103 	    LEND));
1104   LRefIncr(arg);
1105   return arg;
1106 }
1107 
1108 /* The purpose of the function below is to allow the evaluation of
1109  * quoted lists, or lists constructed via cons, car, cdr, or the &rest
1110  * argument of defun: if the car of a list is a symbol and not a
1111  * function call, then it is first replaced by a matching function
1112  * call if possible, and a lake argument is added as second arg.
1113  */
LListSexpr(LList * expr,Lake * lake)1114 static void LListSexpr(LList *expr, Lake *lake)
1115 {
1116   LList *subexpr, *cdr = expr->cdr;
1117   int fidx;
1118 
1119   if (expr->car && expr->car->type != LFUNC && funcfromobj(expr->car, &fidx)) {
1120     /* try to convert into a function name and add a lake argument. */
1121     LList *lakenode = LListNew();
1122 
1123     lakenode->cdr = cdr;
1124     lakenode->car = lake2obj(&lake);
1125 
1126     if (expr->car->type == LSYMBOL) {
1127       /* Builtin function or defun */
1128       LFree(expr->car);
1129       expr->car = LNew(LFUNC, &fidx);
1130       expr->cdr = lakenode;
1131     } else {
1132       /* anonymous lambda expression */
1133       expr->cdr = LListNew();
1134       expr->cdr->car = expr->car;
1135       expr->car = LNew(LFUNC, &fidx);
1136       expr->cdr->cdr = lakenode;
1137     }
1138   }
1139   while (cdr) {
1140     if (expr->car) {
1141       if (expr->car->type == LLAKE) {
1142 	expr->car->cell.p = lake;
1143       } else if (listfromobj(expr->car, &subexpr)) {
1144 	LListSexpr(subexpr, lake);
1145       }
1146     }
1147     cdr = cdr->cdr;
1148   }
1149 }
1150 
1151 LDEFINE(eval, LLOBJECT,
1152 	"(eval EXPR)\n"
1153 	"Evaluate a lisp expression. If EXPR is an unevaluated S-expression "
1154 	"as returned by the \"(quote ...)\" command then the effect will be "
1155 	"as if calling the un-quoted expression directly.")
1156 {
1157   LObject *arg;
1158   LList *sexpr;
1159   Lake *caller;
1160 
1161   LDECLARE(("eval", LBEGIN,
1162 	    LLAKE, &caller,
1163 	    LLOBJECT, &arg,
1164 	    LEND));
1165 
1166   if (listfromobj(arg, &sexpr)) {
1167     LListSexpr(sexpr, caller);
1168   }
1169 
1170   return LEval(arg);
1171 }
1172 
1173 LDEFINE(lambda, LLOBJECT,
1174 	"(lambda (arg1 arg2 ...) EXPR1 ... EXPRN)\n"
1175 	"A lambda expression is like a function. "
1176 	"To \"call\" a lambda expression, it has to be evoked like a "
1177 	"function:\n\n"
1178 	"((lambda (arg) (+ 1 arg)) 2)\n\n"
1179 	"In this example, the value of the entire expression would be 3. "
1180 	"In general, the value of the call will be the value of exprN. "
1181 	"The first list serves to define formal parameters. The values "
1182 	"of the formal parameters can be changed using `(setq ...)'. The "
1183 	"binding will only be in effect during the evaluation of the "
1184 	"lambda-expression. The lambda "
1185 	"expression itself is just a list, starting with the key-word lambda, "
1186 	"followed by several quoted lists; it evaluates to itself if not "
1187 	"called as a function.")
1188 {
1189   LObject *lambda;
1190   LList *arglist;
1191   LList *body;
1192 
1193   LDECLARE(("lambda", LBEGIN,
1194 	    LLITERAL, LLIST, &arglist,
1195 	    LHOLD, LREST, &body,
1196 	    LEND));
1197 
1198   /* We avaluate to ourselves */
1199   lambda = list2obj(&args);
1200   return lambda;
1201 }
1202 
1203 LDEFINE(let, LLOBJECT,
1204 	"(let ARGUMENTS EXPR1 ... EXPRN)\n"
1205 	"Generate a lambda expression from EXRP1 ... EXPRN, with the "
1206 	"argument bindings described by ARGUMENTS. ARGUMENTS is a list "
1207 	"of symbols (bound to nil by default) or lists of the form "
1208 	"`(ARG VALUE)' where ARG is a symbol and not evaluated and VALUE "
1209 	"is a S-expr which is first evaluated, then its value is bound to "
1210 	"ARG. The entire expression evaluates to the value of EXPRN, the "
1211 	"last expression in the body of the statement. The argument list "
1212 	"must be present, but can be empty; in the latter case the "
1213 	"`(let () ...)' statement is equivalent to a `(progn ...)'")
1214 {
1215   if (!LPARSEMODE) {
1216     return LEvalLambda(NULL, args);
1217   } else {
1218     /* We cannot use LParseArgs() to parse the lake into ARGLIST,
1219      * otherwise the parameter names would be turned into function
1220      * calls, and in case of a matching function name the following
1221      * data would be parsed according to the rules of the function
1222      * which is not appropriate here. The strategy is to convert the
1223      * let-expression into an equivalent lambda-expression during
1224      * parsing.
1225      */
1226     LList *lambda;
1227     LList **arglistp;
1228     int quote;
1229     bool par;
1230 
1231     if (!LakeMore(lake) || !LakeNewSexpr(lake)) {
1232       OOGLSyntax(lake->streamin,
1233 		 "Llet(): Reading \"%s\": missing parameter list",
1234 		 LakeName(lake));
1235     }
1236 
1237     /* lambda-expression */
1238     lambda = LListNew();
1239     LListAppend(args, LNew(LLIST, &lambda));
1240     args = args->cdr;
1241 
1242     /* head of lambda expression */
1243     lambda->car = FUNCTOOBJ("lambda");
1244     /* lambda argument list */
1245     lambda->cdr = LListNew();
1246     lambda->cdr->car = LNew(LLIST, NULL);
1247     arglistp = (LList **)&lambda->cdr->car->cell.p;
1248 
1249     /* stash the lake as first argument value */
1250     LListAppend(args, lake2obj(&lake));
1251     args = args->cdr;
1252 
1253     /* argument values then go to args->cdr, if present */
1254 
1255     LakeNextToken(lake, &quote); /* consume '(' */
1256     while (LakeMore(lake)) {
1257       LObject *larg, *lval;
1258       char *arg;
1259 
1260       if ((par = LakeNewSexpr(lake))) {
1261 	/* (ARG VALUE) */
1262 	LakeNextToken(lake, &quote); /* consume '(' */
1263       }
1264       /* fetch the argument name */
1265       if ((larg = LLiteral(lake)) == Lnil || !symbolfromobj(larg, &arg)) {
1266 	OOGLSyntax(lake->streamin,
1267 		   "Llet(): Reading \"%s\": "
1268 		   "argument name missing or not a symbol (`%s'?!)",
1269 		   LakeName(lake), LSummarize(larg));
1270 	goto parsebad;
1271       }
1272 
1273       if (par) {
1274 	/* fetch the argument value */
1275 	lval = LSexpr(lake);
1276 	if (LakeMore(lake)) {
1277 	  OOGLSyntax(lake->streamin,
1278 		     "Llet(): Reading \"%s\": "
1279 		     "excess data in argument definition",
1280 		     LakeName(lake));
1281 	  LFree(lval);
1282 	  goto parsebad;
1283 	}
1284 	LakeNextToken(lake, &quote); /* consume ')' */
1285       } else {
1286 	lval = Lnil;
1287       }
1288 
1289       /* put the argument name into the argument list of the lambda
1290        * expression
1291        */
1292       *arglistp = LListNew();
1293       (*arglistp)->car = larg;
1294       arglistp = &(*arglistp)->cdr;
1295 
1296       /* put the argument value into the value list of the lambda
1297        * function call, i.e. just append to args.
1298        */
1299       LListAppend(args, lval);
1300       args = args->cdr;
1301     }
1302     LakeNextToken(lake, &quote); /* consume ')' */
1303 
1304     /* suck the body of the let statement in */
1305     args = lambda->cdr;
1306     LDECLARE(("let", LBEGIN,
1307 	      LHOLD, LREST, NULL,
1308 	      LEND));
1309 
1310     return Lt; /* not reached */
1311   parsebad:
1312     /* Consume the remainder of the expression */
1313     while (LakeMore(lake)) {
1314       LFree(LSexpr(lake));
1315     }
1316     LakeNextToken(lake, &quote); /* consume ')' */
1317     if (par) {
1318       par = false;
1319       goto parsebad;
1320     }
1321     /* this was for the argument list, now go for the body */
1322     while (LakeMore(lake)) {
1323       LFree(LSexpr(lake));
1324     }
1325     return Lnil;
1326   }
1327 }
1328 
1329 LDEFINE(defun, LLOBJECT,
1330 	"(defun NAME (ARG1 ...) [DOCSTRING] EXPR1 ...)\n"
1331 	"Define a named lambda-expression, that is: define NAME to evaluate "
1332 	"to the lambda-expression \"(lambda (ARG1...) (EXPR1...))\" when "
1333 	"called as a function. Also, install DOCSTRING as response to the "
1334 	"commands \"(help NAME)\" and \"(morehelp NAME)\". Not that DOCSTRING "
1335 	"need not contain the command-synopsis, it is generated automatically. "
1336 	"EXPR1 cannot be a string if DOCSTRING is omitted; it "
1337 	"would be interpreted as the doc-string. The return value of "
1338 	"(defun ...) is the function name.")
1339 {
1340   char *name;
1341   char *helpstring = NULL;
1342   LList *arglist, *body, *arg;
1343   LObject *lambda;
1344   int fidx, nargs, helpsize;
1345   char *help, *argname;
1346 
1347   /* Not pretty standard: in order that our Sexpr0() uses the correct
1348    * function for parsing the arguments of the defun we have to add a
1349    * dummy function entry right at the start. That entry points to
1350    * EvalDefun(), which makes sure we have a LAKE and the remaining
1351    * arguments as LREST list.
1352    */
1353 
1354   if (!LPARSEMODE) {
1355     LDECLARE(("defun", LBEGIN,
1356 	      LSYMBOL, &name,
1357 	      LLITERAL, LLIST, &arglist,
1358 	      LHOLD, LREST, &body,
1359 	      LEND));
1360   } else {
1361     LObject *lname;
1362     char *name;
1363 
1364     /* Dequeue the function name */
1365     if (!LakeMore(lake) ||
1366 	(lname = LLiteral(lake)) == Lnil || !symbolfromobj(lname, &name)) {
1367       OOGLSyntax(lake->streamin,
1368 		 "Ldefun(): Reading \"%s\": missing function name",
1369 		 LakeName(lake));
1370       return Lnil;
1371     }
1372 
1373     /* Append the function name to the argument list */
1374     LListAppend(args, lname);
1375 
1376     /* Bind it. Error recovery is flakey here, because we bind the new
1377      * name even though we do not know yet whether the following
1378      * S-expr is syntactically correct.
1379      */
1380     LDefun(name, LEvalDefun, NULL);
1381 
1382     /* Then proceed with normal argument parsing; this will already
1383      * use the new function binding and the parsing rules of
1384      * LEvalDefun().
1385      */
1386     LDECLARE(("defun", LBEGIN,
1387 	      LLITERAL, LLIST, &arglist,
1388 	      LHOLD, LREST, &body,
1389 	      LEND));
1390   }
1391 
1392   /* evaluation mode */
1393 
1394   /* Fetch the index into the jump table */
1395   if ((fidx = funcindex(name)) < 0) {
1396     OOGLError(0, "Ldefun(%s): Error: LDefun(%s) failed.", name, name);
1397     return Lnil;
1398   }
1399 
1400   /* Extract doc-string and body */
1401   if (body && LFROMOBJ(LSTRING)(body->car, &helpstring)) {
1402     body = body->cdr;
1403   }
1404 
1405   /* Construct a suitable help-string. The heading is auto-generated. */
1406   if (helpstring == NULL) {
1407     helpstring = "Undocumented lisp-function.";
1408   }
1409   helpsize = strlen(helpstring) + strlen(name) + strlen("()\n");
1410   for (nargs = 0, arg = arglist; arg && arg->car; arg = arg->cdr, ++nargs) {
1411     if (!LFROMOBJ(LSYMBOL)(arg->car, &argname)) {
1412       OOGLError(0, "Ldefun(%s): Error: "
1413 		"argument name -- %s -- is not a symbol (an unquoted token).",
1414 		name, LSummarize(arg->car));
1415       return Lnil;
1416     }
1417     helpsize += strlen(argname);
1418   }
1419   helpsize += nargs; /* spaces */
1420 
1421   help = malloc(helpsize+1+ /* safeguard */ 10);
1422 
1423   switch (nargs) {
1424   case 0:
1425     sprintf(help, "(%s)\n%s", name, helpstring);
1426     break;
1427   case 1:
1428     LFROMOBJ(LSYMBOL)(arglist->car, &argname);
1429     sprintf(help, "(%s %s)\n%s", name, argname, helpstring);
1430     break;
1431   default:
1432     helpsize = sprintf(help, "(%s", name);
1433     for (arg = arglist; arg; arg = arg->cdr) {
1434       LFROMOBJ(LSYMBOL)(arg->car, &argname);
1435       helpsize += sprintf(help + helpsize, " %s", argname);
1436     }
1437     strcpy(help + helpsize, ")\n"); helpsize += 2;
1438     strcpy(help + helpsize, helpstring);
1439     break;
1440   }
1441 
1442   /* Defining a function should not really be timing critical, so we
1443    * use the slow C-interface here:
1444    */
1445   lambda = LEvalFunc("lambda", LLIST, arglist, LREST, body, LEND);
1446   if (lambda == Lnil) {
1447     free(help);
1448     OOGLError(0, "Ldefun(%s): Error: could not generate lambda-expression.",
1449 	      name);
1450     return Lnil;
1451   }
1452   functable[fidx].lambda = lambda;
1453   functable[fidx].help = help;
1454 
1455   LHelpDef(functable[fidx].name, functable[fidx].help);
1456 
1457   return LTOOBJ(LSYMBOL)(&name);
1458 }
1459 
1460 LDEFINE(setq, LLOBJECT,
1461 	"(setq SYM SEXPR)\n"
1462 	"Bind the symbold SYM to the value of SEXPR. SYM must be an "
1463 	"unqualified symbol, i.e. not quoted, and literal:\n\n"
1464 	"(setq \"foo\" bar)\n\n"
1465 	"will not work. Likewise\n\n"
1466 	"(setq (bar STUFF) foo)\n\n"
1467 	"will also not work, even if (bar ...) would evaluate to an "
1468 	"unqualified symbol: varible names must be literals. "
1469 	"Note that calling `(setq SYM ...)' will alter the value of "
1470 	"SYM within the current name-space: if SYM, e.g., is bound as "
1471 	"local variable by a lambda, let or defun expression, then "
1472 	"`(setq SYM ...)' will change the value of the local variable, "
1473 	"the global binding will remain unchanged. "
1474 	"It is NOT possible to un-bind a symbol. However, subsequent "
1475 	"`(setq SYM ...)' invocations will re-bind SYM to another value "
1476 	"and free the lisp-object previously bound to SYM.")
1477 {
1478   Lake *caller;
1479   LObject *sym, *val;
1480 
1481   LDECLARE(("setq", LBEGIN,
1482 	    LLAKE, &caller,
1483 	    LLITERAL, LLOBJECT, &sym,
1484 	    LLOBJECT, &val,
1485 	    LEND));
1486 
1487   if (sym->type != LSYMBOL) {
1488     OOGLSyntax(caller->streamin,
1489 	       "Lsetq(): Reading \"%s\": "
1490 	       "trying to bind symbol(?) `%s': "
1491 	       "variable names need to be literals (unquoted atoms)",
1492 	       LakeName(caller), LSummarize(sym));
1493     return Lnil;
1494   }
1495 
1496   namespace_put(lambda_namespace, LSYMBOLVAL(sym), val, true);
1497 
1498   return LRefIncr(val);
1499 }
1500 
1501 /* A (while ...) statement is very imported: although in principle a
1502  * loop can be emulated by a recursion, such thing as _wanted_
1503  * infinite loops can only be constructed by a real loop-statemnt like
1504  * this. Actually, one would want to be able to enter Geomview's
1505  * main-loop from inside a lisp script. This, however, is not our
1506  * concern. This module does not need to pay attention to that stuff.
1507  */
1508 LDEFINE(while, LVOID,
1509 	"(while TEST BODY)\n"
1510 	"Iterate: \"evaluate TEST, if non nil, evaluate BODY\".")
1511 {
1512   LObject *test, *body, *val, *cp;
1513 
1514   LDECLARE(("while", LBEGIN,
1515 	    LHOLD, LLOBJECT, &test,
1516 	    LHOLD, LLOBJECT, &body,
1517 	    LEND));
1518   while ((val = LEval(cp = LCopy(test))) != Lnil) {
1519     LFree(val);
1520     LFree(cp);
1521     val = LEval(cp = LCopy(body));
1522     LFree(val);
1523     LFree(cp);
1524   }
1525   LFree(val);
1526   LFree(cp);
1527   return Lt;
1528 }
1529 
1530 LDEFINE(if, LLOBJECT,
1531 	"(if TEST EXPR1 [EXPR2])\n\
1532 	Evaluates TEST; if TEST returns a non-nil value, returns the\n\
1533 	value of EXPR1.  If TEST returns nil, returns the value of\n\
1534 	EXPR2 if EXPR2 is present, otherwise returns nil.")
1535 {
1536   LObject *test, *tclause, *fclause=NULL;
1537   LDECLARE(("if", LBEGIN,
1538 	    LLOBJECT, &test,
1539 	    LHOLD, LLOBJECT, &tclause,
1540 	    LOPTIONAL,
1541 	    LHOLD, LLOBJECT, &fclause,
1542 	    LEND));
1543   if (test != Lnil) {
1544     return LEval(tclause);
1545   } else if (fclause) {
1546     return LEval(fclause);
1547   } else {
1548     return Lnil;
1549   }
1550 }
1551 
1552 LDEFINE(not, LINT,
1553 	"(not EXPR)\n\
1554 	Evaluates EXPR; if EXPR returns a non-nil value, returns nil,\n\
1555 	if EXPR returns nil, return t.")
1556 {
1557   LObject *expr;
1558 
1559   LDECLARE(("not", LBEGIN,
1560 	    LLOBJECT, &expr,
1561 	    LEND));
1562   if (expr != Lnil) {
1563     return Lnil;
1564   } else {
1565     return Lt;
1566   }
1567 }
1568 
1569 LDEFINE(or, LLOBJECT,
1570 	"(or EXPR1 EXPR2\n\
1571 	Evaluates EXPR1; if EXPR1 returns non-nil, return its value,\n\
1572         if EXPR1 returns nil, evaluate EXPR2 and return its value.")
1573 {
1574   LObject *expr1, *expr2;
1575   LDECLARE(("or", LBEGIN,
1576 	    LLOBJECT, &expr1,
1577 	    LHOLD, LLOBJECT, &expr2,
1578 	    LEND));
1579   if (expr1 != Lnil) {
1580     /* arguments do not survive the life-time of a function */
1581     return LRefIncr(expr1);
1582   } else {
1583     return LEval(expr2);
1584   }
1585 }
1586 
1587 LDEFINE(and, LLOBJECT,
1588 	"(and EXPR1 EXPR2\n\
1589 	Evaluate EXPR1 and EXPR2 and return t if both return non-nil,\n\
1590 	otherwise return nil.")
1591 {
1592   LObject *expr1, *expr2;
1593   LDECLARE(("and", LBEGIN,
1594 	    LLOBJECT, &expr1,
1595 	    LLOBJECT, &expr2,
1596 	    LEND));
1597   return (expr1 != Lnil && expr2 != Lnil) ? Lt : Lnil;
1598 }
1599 
1600 LDEFINE(greater, LLOBJECT,
1601 	"(> EXPR1 EXPR2)\n\
1602 	Returns t if EXPR1 is greater than EXPR2.  EXPR1 and EXPR2 should\n\
1603 	be either both integers or floats, or both strings.")
1604 {
1605   LObject *expr1, *expr2;
1606   LDECLARE((">", LBEGIN,
1607 	    LLOBJECT, &expr1,
1608 	    LLOBJECT, &expr2,
1609 	    LEND));
1610   if (LCompare(">", expr1, expr2)==1) return Lt;
1611   else return Lnil;
1612 }
1613 
1614 LDEFINE(less, LINT,
1615 	"(< EXPR1 EXPR2)\n\
1616 	Returns t if EXPR1 is less than EXPR2.  EXPR1 and EXPR2 should\n\
1617 	be either both integers or floats, or both strings.")
1618 {
1619   LObject *expr1, *expr2;
1620   LDECLARE(("<", LBEGIN,
1621 	    LLOBJECT, &expr1,
1622 	    LLOBJECT, &expr2,
1623 	    LEND));
1624   if (LCompare("<", expr1, expr2)==-1) return Lt;
1625   else return Lnil;
1626 }
1627 
1628 LDEFINE(equal, LINT,
1629 	"(= EXPR1 EXPR2)\n\
1630 	Returns t if EXPR1 is equal to EXPR2.  EXPR1 and EXPR2 should\n\
1631 	be either both integers or floats, or both strings.")
1632 {
1633   LObject *expr1, *expr2;
1634   LDECLARE(("=", LBEGIN,
1635 	    LLOBJECT, &expr1,
1636 	    LLOBJECT, &expr2,
1637 	    LEND));
1638   if (LCompare("=", expr1, expr2)==0) return Lt;
1639   else return Lnil;
1640 }
1641 
1642 /* Note: comparison is promoted to the weakest numerical type, with
1643  * the ordering LINT < LLONG < LFLOAT < LSTRING.
1644  *
1645  * The return value is ((expr1 > expr2) - (expr1 < expr2))
1646  */
LCompare(const char * name,LObject * expr1,LObject * expr2)1647 static int LCompare(const char *name, LObject *expr1, LObject *expr2)
1648 {
1649   char   *s1, *s2;
1650   double d1, d2;
1651   long   l1, l2;
1652   int    i1, i2;
1653 
1654   if (LFROMOBJ(LINT)(expr1, &i1) && LFROMOBJ(LINT)(expr2, &i2)) {
1655     return (i1 > i2) - (i1 < i2);
1656   }
1657   if (LFROMOBJ(LLONG)(expr1, &l1) && LFROMOBJ(LLONG)(expr2, &l2)) {
1658     return (l1 > l2) - (l1 < l2);
1659   }
1660   if (LFROMOBJ(LDOUBLE)(expr1, &d1) && LFROMOBJ(LDOUBLE)(expr2, &d2)) {
1661     return (d1 > d2) - (d1 < d2);
1662   }
1663   if (LFROMOBJ(LSTRING)(expr1, &s1) && LFROMOBJ(LSTRING)(expr2, &s2)) {
1664     return strcmp(s1, s2);
1665   }
1666   OOGLError(0, "%s: arg1 and arg2 must at least be strings to be compared.",
1667 	    name);
1668   return 0;
1669 }
1670 
1671 LDEFINE(add, LLOBJECT,
1672 	"(+ EXPR1 EXPR2)\n"
1673 	"Adds EXPR1 to EXPR2 if both convert to a numerical value.")
1674 {
1675   LObject *expr1, *expr2;
1676   double d1, d2;
1677   long   l1, l2;
1678   int    i1, i2;
1679 
1680   LDECLARE(("+", LBEGIN,
1681 	    LLOBJECT, &expr1,
1682 	    LLOBJECT, &expr2,
1683 	    LEND));
1684 
1685   if (LFROMOBJ(LINT)(expr1, &i1) && LFROMOBJ(LINT)(expr2, &i2)) {
1686     return LINTTOOBJ(i1 + i2);
1687   }
1688   if (LFROMOBJ(LLONG)(expr1, &l1) && LFROMOBJ(LLONG)(expr2, &l2)) {
1689     return LLONGTOOBJ(l1 + l2);
1690   }
1691   if (LFROMOBJ(LDOUBLE)(expr1, &d1) && LFROMOBJ(LDOUBLE)(expr2, &d2)) {
1692     return LDOUBLETOOBJ(d1 + d2);
1693   }
1694   OOGLError(0, "\"+\": ARG1 and ARG2 must be numerical values.");
1695   OOGLError(0, "\"+\": ARG1: %s", LSummarize(expr1));
1696   OOGLError(0, "\"+\": ARG2: %s", LSummarize(expr2));
1697   return Lnil;
1698 }
1699 
1700 LDEFINE(substract, LLOBJECT,
1701 	"(- EXPR1 [EXPR2])\n"
1702 	"Substracts EXPR1 from EXPR2 if both convert to a numerical value. "
1703 	"If EXPR2 is omitted negate EXPR1 if it converts to a numerical value.")
1704 {
1705   LObject *expr1, *expr2 = NULL;
1706   double d1, d2;
1707   long   l1, l2;
1708   int    i1, i2;
1709 
1710   LDECLARE(("-", LBEGIN,
1711 	    LLOBJECT, &expr1,
1712 	    LOPTIONAL, LLOBJECT, &expr2,
1713 	    LEND));
1714 
1715   if (expr2) {
1716     if (LFROMOBJ(LINT)(expr1, &i1) && LFROMOBJ(LINT)(expr2, &i2)) {
1717       return LINTTOOBJ(i1 - i2);
1718     }
1719     if (LFROMOBJ(LLONG)(expr1, &l1) && LFROMOBJ(LLONG)(expr2, &l2)) {
1720       return LLONGTOOBJ(l1 - l2);
1721     }
1722     if (LFROMOBJ(LDOUBLE)(expr1, &d1) && LFROMOBJ(LDOUBLE)(expr2, &d2)) {
1723       return LDOUBLETOOBJ(d1 - d2);
1724     }
1725     OOGLError(0, "\"-\": ARG1 and ARG2 must be numerical values.");
1726     OOGLError(0, "\"-\": ARG1: %s", LSummarize(expr1));
1727     OOGLError(0, "\"-\": ARG2: %s", LSummarize(expr2));
1728   } else {
1729     if (LFROMOBJ(LINT)(expr1, &i1)) {
1730       if (i1 == 0 || -i1 != i1) {
1731 	return LINTTOOBJ(-i1);
1732       }
1733     }
1734     if (LFROMOBJ(LLONG)(expr1, &l1)) {
1735       if (l1 == 0 || -l1 != l1) {
1736 	return LLONGTOOBJ(-l1);
1737       }
1738     }
1739     if (LFROMOBJ(LDOUBLE)(expr1, &d1)) {
1740       return LDOUBLETOOBJ(-d1);
1741     }
1742     OOGLError(0, "\"-\": ARG %s  must be a numerical value.",
1743 	      LSummarize(expr1));
1744   }
1745   return Lnil;
1746 }
1747 
1748 LDEFINE(multiply, LLOBJECT,
1749 	"(* EXPR1 EXPR2)\n"
1750 	"Multiplies EXPR1 with EXPR2 if both convert to a numerical value.")
1751 {
1752   LObject *expr1, *expr2;
1753   double d1, d2;
1754   long   l1, l2;
1755   int    i1, i2;
1756 
1757   LDECLARE(("*", LBEGIN,
1758 	    LLOBJECT, &expr1,
1759 	    LLOBJECT, &expr2,
1760 	    LEND));
1761 
1762   if (LFROMOBJ(LINT)(expr1, &i1) && LFROMOBJ(LINT)(expr2, &i2)) {
1763     return LLONGTOOBJ((long)i1 * (long)i2);
1764   }
1765   if (LFROMOBJ(LLONG)(expr1, &l1) && LFROMOBJ(LLONG)(expr2, &l2)) {
1766     if ((l2 == 0 || l1 * l2 / l2 == l1) ||
1767 	(l1 == 0 || l2 * l1 / l1 == l2)) {
1768       return LLONGTOOBJ(l1 * l2);
1769     }
1770   }
1771   if (LFROMOBJ(LDOUBLE)(expr1, &d1) && LFROMOBJ(LDOUBLE)(expr2, &d2)) {
1772     return LDOUBLETOOBJ(d1 * d2);
1773   }
1774   OOGLError(0, "\"*\": ARG1 and ARG2 must be numerical values.");
1775   OOGLError(0, "\"*\": ARG1: %s", LSummarize(expr1));
1776   OOGLError(0, "\"*\": ARG2: %s", LSummarize(expr2));
1777   return Lnil;
1778 }
1779 
1780 LDEFINE(divide, LLOBJECT,
1781 	"(/ EXPR1 EXPR2)\n"
1782 	"Divides EXPR1 by EXPR2 if both convert to a numerical value.")
1783 {
1784   LObject *expr1, *expr2;
1785   double d1, d2;
1786   LDECLARE(("/", LBEGIN,
1787 	    LLOBJECT, &expr1,
1788 	    LLOBJECT, &expr2,
1789 	    LEND));
1790 
1791   if (LFROMOBJ(LDOUBLE)(expr1, &d1) && LFROMOBJ(LDOUBLE)(expr2, &d2)) {
1792     return LDOUBLETOOBJ(d1 / d2);
1793   }
1794   OOGLError(0, "\"/\": ARG1 and ARG2 must be numerical values.");
1795   OOGLError(0, "\"/\": ARG1: %s", LSummarize(expr1));
1796   OOGLError(0, "\"/\": ARG2: %s", LSummarize(expr2));
1797   return Lnil;
1798 }
1799 
1800 LDEFINE(remainder, LLOBJECT,
1801 	"(mod EXPR1 EXPR2)\n"
1802 	"Divides EXPR1 by EXPR2 which must be integers and "
1803 	"returns the remainder.")
1804 {
1805   LObject *expr1, *expr2;
1806   long   l1, l2;
1807   int    i1, i2;
1808 
1809   LDECLARE(("mod", LBEGIN,
1810 	    LLOBJECT, &expr1,
1811 	    LLOBJECT, &expr2,
1812 	    LEND));
1813 
1814   if (LFROMOBJ(LINT)(expr1, &i1) && LFROMOBJ(LINT)(expr2, &i2)) {
1815     return LINTTOOBJ(i1 % i2);
1816   }
1817   if (LFROMOBJ(LLONG)(expr1, &l1) && LFROMOBJ(LLONG)(expr2, &l2)) {
1818     return LLONGTOOBJ(l1 % l2);
1819   }
1820   OOGLError(0, "\"mod\": ARG1 and ARG2 must be integer values.");
1821   OOGLError(0, "\"mod\": ARG1: %s", LSummarize(expr1));
1822   OOGLError(0, "\"mod\": ARG2: %s", LSummarize(expr2));
1823   return Lnil;
1824 }
1825 
1826 LDEFINE(truncate, LLOBJECT,
1827 	"(truncate EXPR\n"
1828 	"Truncates EXPR which must convert to a numerical value, that is, "
1829 	"round EXPR towards zero to an integral value.")
1830 {
1831   LObject *expr1;
1832   double d1;
1833   long   l1;
1834   int    i1;
1835 
1836   LDECLARE(("truncate", LBEGIN,
1837 	    LLOBJECT, &expr1,
1838 	    LEND));
1839 
1840   if (LFROMOBJ(LINT)(expr1, &i1)) {
1841     return LINTTOOBJ(i1);
1842   }
1843   if (LFROMOBJ(LLONG)(expr1, &l1)) {
1844     return LLONGTOOBJ(l1);
1845   }
1846   if (LFROMOBJ(LDOUBLE)(expr1, &d1)) {
1847     return LLONGTOOBJ((long)d1);
1848   }
1849   OOGLError(0, "\"-\": ARG %s  must be a numerical value.",
1850 	    LSummarize(expr1));
1851   return Lnil;
1852 }
1853 
1854 LDEFINE(sgi, LINT,
1855 	"(sgi)\n\
1856 	Returns t if running on an sgi machine, nil if not")
1857 {
1858   LDECLARE(("sgi", LBEGIN,
1859 	    LEND));
1860   if (strcmp(MACHTYPE,"sgi")==0) return Lt;
1861   return Lnil;
1862 }
1863 
1864 LDEFINE(NeXT, LINT,
1865 	"(NeXT)\n\
1866 	Returns t if running on a NeXT, nil if not")
1867 {
1868   LDECLARE(("NeXT", LBEGIN,
1869 	    LEND));
1870   if (strcmp(MACHTYPE,"next")==0) return Lt;
1871   return Lnil;
1872 }
1873 
1874 
1875 
1876 LDEFINE(progn, LLOBJECT,
1877 	"(progn STATEMENT [ ... ])\n\
1878 	evaluates each STATEMENT in order and returns the value of the\n\
1879 	last one.  Use progn to group a collection of commands together,\n\
1880 	forcing them to be treated as a single command.")
1881 {
1882   LObject *val=NULL;
1883   LList *arglist = NULL;
1884 
1885   LDECLARE(("progn", LBEGIN,
1886 	    LHOLD,
1887 	    LREST, &arglist,
1888 	    LEND));
1889   for( ; arglist != NULL; arglist = arglist->cdr) {
1890     LFree(val);
1891     val = LEval(arglist->car);
1892   }
1893   return val;
1894 }
1895 
LListShow(LList * list)1896 void LListShow(LList *list)
1897 {
1898   LListWrite(stderr, list);
1899 }
1900 
LListSummarize(LList * list)1901 const char *LListSummarize(LList *list)
1902 {
1903   const char *msg;
1904   LObject *lobj;
1905 
1906   lobj = LNew(LLIST, &list);
1907   msg = LSummarize(lobj);
1908   lobj->cell.p = NULL;
1909   LFree(lobj);
1910 
1911   return msg;
1912 }
1913 
1914 /*
1915  * Lisp object implementation
1916  */
1917 static DEF_FREELIST(LObject);
1918 
LNew(LType * type,void * vcell)1919 LObject *LNew(LType *type, void *vcell)
1920 {
1921   LCell *cell = (LCell *)vcell;
1922   LObject *obj;
1923 
1924   FREELIST_NEW(LObject, obj);
1925 
1926   obj->type = type;
1927   obj->ref = 1;
1928   if (!cell) {
1929     memset(&obj->cell, 0, sizeof(obj->cell));
1930   } else {
1931     memcpy(&obj->cell, cell, LSIZE(type));
1932   }
1933   return obj;
1934 }
1935 
LWrite(FILE * fp,LObject * obj)1936 void LWrite(FILE *fp, LObject *obj)
1937 {
1938   (*obj->type->write)(fp, &(obj->cell));
1939 }
1940 
LWriteFile(const char * fname,LObject * obj)1941 void LWriteFile(const char *fname, LObject *obj)
1942 {
1943   FILE *fp = fopen(fname, "w");
1944   if (fp != NULL) {
1945     LWrite(fp, obj);
1946     fclose(fp);
1947   } else {
1948     OOGLError(0, "LWriteFile: can't create file %s",fname);
1949   }
1950 }
1951 
LShow(LObject * obj)1952 void LShow(LObject *obj)
1953 {
1954   LWrite(stderr, obj);
1955 }
1956 
_LFree(LObject * obj)1957 void _LFree(LObject *obj)
1958 {
1959   (*obj->type->free)(&(obj->cell));
1960   FREELIST_FREE(LObject, obj);
1961 }
1962 
1963 #if 0 /* now as inline functions in lisp.h */
1964 LObject *LCopy(LObject *obj)
1965 {
1966   if (obj == Lnil) return Lnil;
1967   if (obj == Lt) return Lt;
1968   return LTOOBJ(obj->type)(&(obj->cell));
1969 }
1970 
1971 LObject *LRefIncr(LObject *obj)
1972 {
1973   ++(obj->ref);
1974   return obj;
1975 }
1976 
1977 void LRefDecr(LObject *obj)
1978 {
1979   --(obj->ref);
1980 }
1981 #endif
1982 
1983 /* lambda-expression argument name-space handling */
1984 
1985 /* push a new namespace */
namespace_push(LNameSpace ** ns,LNameSpace * new_ns)1986 static inline void namespace_push(LNameSpace **ns, LNameSpace *new_ns)
1987 {
1988   if (new_ns) {
1989     new_ns->parser = fsa_initialize(NULL, (void *)REJECT);
1990     VVINIT(new_ns->table, LObject *, 8);
1991     new_ns->next = *ns;
1992     *ns = new_ns;
1993   }
1994 }
1995 
1996 /* pop the current name-space and destroy it */
namespace_pop(LNameSpace ** ns)1997 static inline void namespace_pop(LNameSpace **ns)
1998 {
1999   int i;
2000 
2001   if (*ns) {
2002     for (i = 0; i < VVCOUNT((*ns)->table); i++) {
2003       LFree(VVEC((*ns)->table, LObject *)[i]);
2004     }
2005     vvfree(&(*ns)->table);
2006     fsa_delete((*ns)->parser);
2007   }
2008 
2009   *ns = (*ns)->next;
2010 }
2011 
_namespace_get(LNameSpace * ns,char * name)2012 static inline LObject **_namespace_get(LNameSpace *ns, char *name)
2013 {
2014   int idx = REJECT;
2015 
2016   idx = (int)(long)fsa_parse(ns->parser, name);
2017   if (idx == REJECT) {
2018     return NULL;
2019   }
2020   return VVEC(ns->table, LObject *)+idx;
2021 }
2022 
namespace_get(LNameSpace * ns,char * name)2023 static inline LObject *namespace_get(LNameSpace *ns, char *name)
2024 {
2025   LObject **obj;
2026 
2027   if (ns == NULL) {
2028     return NULL;
2029   }
2030 
2031   do {
2032     obj = _namespace_get(ns, name);
2033   } while (obj == NULL && (ns = ns->next) != NULL);
2034 
2035   return obj ? LRefIncr(*obj) : NULL;
2036 }
2037 
2038 static inline bool
namespace_put(LNameSpace * ns,char * name,LObject * value,bool overwrite)2039 namespace_put(LNameSpace *ns, char *name, LObject *value, bool overwrite)
2040 {
2041   int idx;
2042   LObject **var;
2043 
2044   if ((var = _namespace_get(ns, name)) != NULL) {
2045     if (!overwrite) {
2046       return false;
2047     }
2048     LFree(*var);
2049   } else { /* create a new entry */
2050     idx = VVCOUNT(ns->table);
2051     var = VVAPPEND(ns->table, LObject *);
2052     fsa_install(ns->parser, name, (void *)(long)idx);
2053   }
2054   *var = LRefIncr(value);
2055   return true;
2056 }
2057 
2058 /********************** end of argument name-space ****************************/
2059 
2060 /* Extract body, parameter names and parameter values from a lambda
2061  * expression. Return false if LAMBDA is not a lambda expression.
2062  *
2063  * args and body maybe NULL in which case only the checking is done.
2064  */
lambdafromobj(LObject * lambda,LList ** args,LList ** body)2065 static inline bool lambdafromobj(LObject *lambda, LList **args, LList **body)
2066 {
2067   int idx;
2068   LList *llist;
2069 
2070   if (lambda == NULL || !LFROMOBJ(LLIST)(lambda, &llist)) {
2071     return false; /* lambda expressions are lists */
2072   }
2073   if (!funcfromobj(llist->car, &idx) || functable[idx].fptr != Llambda) {
2074     return false; /* not a lambda expression */
2075   }
2076   if (llist->cdr == NULL ||
2077       llist->cdr->car == NULL ||
2078       llist->cdr->car->type != LLIST) {
2079     return false; /* parameters must be stored in a list (and there
2080 		   * must be a parameter list, at least an empty
2081 		   * one) */
2082   }
2083 
2084   if (args) {
2085     LFROMOBJ(LLIST)(llist->cdr->car, args);
2086   }
2087 
2088   /* Remaining stuff is generic, further checking is done when
2089    * assigning the parameter values.
2090    */
2091   if (body) {
2092     *body = llist->cdr->cdr; /* body is the tail of the entire list */
2093   }
2094 
2095   return true;
2096 }
2097 
2098 /* Bind the values given in ARGVALS to the names given in ARGS within
2099  * the name-space defined by ARGNS. LAKE and CALL are only used to
2100  * report syntax errors.
2101  */
BindLambdaParameters(Lake * lake,LList * call,LNameSpace * argns,LList * args,LList * argvals)2102 static inline bool BindLambdaParameters(Lake *lake, LList *call,
2103 					LNameSpace *argns,
2104 					LList *args, LList *argvals)
2105 {
2106   LObject *lval;
2107   bool rest = false, optional = false;
2108   int ngot = 0;
2109   int nreq = 0;
2110   int nargs = 0;
2111 
2112   for (; args; args = args->cdr) {
2113     char *argname;
2114 
2115     lval = NULL;
2116     if (!LFROMOBJ(LSYMBOL)(args->car, &argname)) {
2117       char *sumcall = strdup(LListSummarize(call));
2118       OOGLSyntax(lake->streamin,
2119 		 "LParseLambda: Reading \"%s\": parsing \"%s\": "
2120 		 "parameter name `%s' is not a symbol (unquoted atom)",
2121 		 LakeName(lake), sumcall, LSummarize(args->car));
2122       free(sumcall);
2123       goto errorout;
2124     }
2125     if (strcmp("&rest", argname) == 0) {
2126       optional = rest = true; /* rest implies optional */
2127       continue;
2128     } else if (strcmp("&optional", argname) == 0) {
2129       optional = true;
2130       continue;
2131     }
2132     ++nargs;
2133     nreq += !optional;
2134     if (rest) {
2135       lval = argvals ? LLISTTOOBJ(argvals) : Lnil;
2136     } else {
2137       lval = argvals ? LRefIncr(argvals->car) : Lnil;
2138     }
2139     if (!namespace_put(argns, argname, lval, false)) {
2140       OOGLSyntax(lake->streamin,
2141 		 "BindLambdaParameters: Reading \"%s\": parsing \"%s\": "
2142 		 "duplicate parameter name `%s'",
2143 		 LakeName(lake), LListSummarize(call), argname);
2144       goto errorout;
2145     }
2146     ngot += argvals != NULL;
2147     LFree(lval);
2148     if (rest) {
2149       args = args->cdr;
2150       break;
2151     }
2152     if (argvals) {
2153       argvals = argvals->cdr;
2154     }
2155   }
2156 
2157   /* Error checking */
2158   if (rest && args) {
2159     char *sumcall = strdup(LListSummarize(call));
2160     OOGLSyntax(lake->streamin,
2161 	       "BindLambdaParameters: Reading \"%s\": parsing \"%s\": "
2162 	       "excess argument names after `&rest' parameter: `%s'",
2163 	       LakeName(lake), sumcall, LListSummarize(args));
2164     free(sumcall);
2165     goto errorout;
2166   } else if (ngot < nreq) {
2167     OOGLSyntax(lake->streamin,
2168 	       "BindLambdaParameters: Reading \"%s\": parsing \"%s\": "
2169 	       "missing parameter values",
2170 	       LakeName(lake), LListSummarize(call));
2171     goto errorout;
2172   } else if (ngot > nargs) {
2173     char *sumcall = strdup(LListSummarize(call));
2174     OOGLSyntax(lake->streamin,
2175 	       "BindLambdaParameters: Reading \"%s\": parsing \"%s\": "
2176 	       "excess parameter values: `%s'",
2177 	       LakeName(lake), sumcall, LListSummarize(argvals));
2178     free(sumcall);
2179     goto errorout;
2180   }
2181   return true;
2182 
2183  errorout:
2184   LFree(lval);
2185   return false;
2186 }
2187 
2188 /* Copy the body of a lambda expression and substitute LAKE for each
2189  * lake argument. This is necessary because (setq ...) can operate on a
2190  * lambda-expression, and the lambda-expression could also stem from a
2191  * (defun ...). In both case the lake arguments stored in the original
2192  * body are out of date.
2193  */
LBody(LList * lbody,Lake * lake)2194 static LList *LBody(LList *lbody, Lake *lake)
2195 {
2196   LList *body;
2197 
2198   if (!lbody) {
2199     return NULL;
2200   }
2201   body = LListNew();
2202   if (lbody->car) {
2203     body->car = LCopy(lbody->car);
2204     if (body->car->type == LLAKE) {
2205       body->car->cell.p = lake;
2206     }
2207   }
2208   body->cdr = LBody(lbody->cdr, lake);
2209   return body;
2210 }
2211 
2212 /* Evaluate a lambda-expression or a defun; convert an anonymous
2213  * lambda-expression into a progn, convert a defun into the named
2214  * function. This function has a special calling convention during
2215  * parse-mode: it must be called like
2216  *
2217  * (\a\bEvalLambda (lambda ...) ...)
2218  *
2219  * That is, the argument list already contains the lambda expression
2220  * as first argument.
2221  */
2222 LDEFINE(EvalLambda, LLOBJECT,
2223 	"\a\b(EvalLambda (lambda ...) (args))\n"
2224 	"Evaluate the given lambda-expression with the given arguments. "
2225 	"Internal use only. DO NOT USE THIS FUNCTION.")
2226 {
2227   LNameSpace lambda_ns;
2228   Lake *caller;
2229   LList *argvals, *largs, *lbody;
2230   LObject *val, *lexpr, *body;
2231 
2232   if (!LPARSEMODE) {
2233     /* The first LDECLARE after LDEFINE wins, so make sure this is the
2234        definition suitable for l_EvalLambda(). */
2235     LDECLARE(("\a\bEvalLambda", LBEGIN,
2236 	      LHOLD, LLOBJECT, &lexpr,
2237 	      LLAKE, &caller,
2238 	      LREST, &argvals,
2239 	      LEND));
2240   } else {
2241     /* In parse mode there is no lambda expression, it is added by
2242      * LSexpr0() automatically.
2243      */
2244     LDECLARE(("\a\bEvalLambda", LBEGIN,
2245 	      LLAKE, &caller,
2246 	      LREST, &argvals,
2247 	      LEND));
2248   }
2249 
2250   /* When we reach here we are in execution mode. */
2251   if (!lambdafromobj(lexpr, &largs, &lbody)) {
2252     return Lnil;
2253   }
2254 
2255   /* push a new name-space */
2256   namespace_push(&lambda_namespace, &lambda_ns);
2257   if (!BindLambdaParameters(caller, args->cdr, &lambda_ns, largs, argvals)) {
2258     namespace_pop(&lambda_namespace);
2259     return Lnil;
2260   }
2261 
2262   /* We have to copy the lambda-expression because assign args will
2263    * substitute the evaluated function calls into the argument lists.
2264    */
2265   body = LLISTTOOBJ(NULL);
2266   body->cell.p = LListNew();
2267   LLISTVAL(body)->car = FUNCTOOBJ("progn");
2268   LLISTVAL(body)->cdr = LBody(lbody, caller); /* copy with lake substitution */
2269 
2270   /* We can now simply return LEval() which will evaluate body in the
2271    * context of the given name-space; we use Lprogn() for this
2272    * purpose.
2273    */
2274   val = LEval(body);
2275 
2276   LFree(body);
2277 
2278   /* pop the saved name-space */
2279   namespace_pop(&lambda_namespace);
2280 
2281   return val;
2282 }
2283 
2284 /* Evaluate a (defun ...). This function is what is entered into the
2285  * function-table to evaluate a named lambda expression. The hard work
2286  * is done in LEvalLambda(), we simply call that function with the
2287  * lambda expression saved in the function table.
2288  *
2289  * To allow recursion we must be careful; the actual parsing of the
2290  * substituted lambda-expression must go to the evaluation pass. For
2291  * this purpose we must remember the lake as hidden argument.
2292  */
2293 LDEFINE(EvalDefun, LLOBJECT,
2294 	"(\a\bEvalDefun EXPR)\n"
2295 	"Internal function which evaluates EXPR as a defun, i.e. a named "
2296 	"lambda-expression. DO NOT USE THIS FUNCTION.")
2297 {
2298   Lake *caller;
2299   LList *lambda, *argvals;
2300   LObject *val;
2301   int fidx;
2302 
2303   LDECLARE(("\a\bEvalDefun", LBEGIN,
2304 	    LLAKE, &caller,
2305 	    LREST, &argvals,
2306 	    LEND));
2307 
2308   /* Forward everything to the eval-step of LEvalLambda(), then
2309    * evaluate the object returned by LEvalLambda() and return that
2310    * value to the caller.
2311    */
2312   if (!LFROMOBJ(LFUNC)(args->car, &fidx) || functable[fidx].lambda == NULL) {
2313     /* should not happen, but ... */
2314     return Lnil;
2315   }
2316 
2317   lambda = LListNew();
2318   lambda->car = LRefIncr(functable[fidx].lambda);
2319   lambda->cdr = args->cdr;
2320   args->cdr = lambda;
2321 
2322   /* Invoke LEvalLambda() in evaluation mode */
2323   val = LEvalLambda(NULL, args);
2324 
2325   args->cdr = lambda->cdr;
2326   lambda->cdr = NULL; /* avoid freeing the argument list */
2327   LListFree(lambda);
2328 
2329   return val;
2330 }
2331 
2332 /* LSexpr() uses special parsing on lists; changes function names to
2333    function pointers, and calls the function to parse the arguments */
LSexpr(Lake * lake)2334 LObject *LSexpr(Lake *lake)
2335 {
2336   return LSexpr0(lake, LIST_FUNCTION);
2337 }
2338 
2339 /* LLiteral() uses literal parsing; lists are not interpreted
2340    as function calls */
LLiteral(Lake * lake)2341 LObject *LLiteral(Lake *lake)
2342 {
2343   return LSexpr0(lake, LIST_LITERAL);
2344 }
2345 
2346 /* LEvalSexpr() both parses and evaluates the requested expression. */
LEvalSexpr(Lake * lake)2347 LObject *LEvalSexpr(Lake *lake)
2348 {
2349   LObject *args, *val;
2350 
2351   args = LSexpr0(lake, LIST_EVAL);
2352   val = LEval(args);
2353   LFree(args);
2354   return val;
2355 }
2356 
ParseArg(LType * type,Lake * lake)2357 static inline LObject *ParseArg(LType *type, Lake *lake)
2358 {
2359   if (LakeNewSexpr(lake)) {
2360     /* ok, its a S-expr, do not invoke the type specific parser, but
2361      * parse it as a sexpr.
2362      */
2363     return LSexpr(lake);
2364   } else {
2365     /* otherwise invoke the type-specific parser */
2366     return LPARSE(type)(lake);
2367   }
2368 }
2369 
2370 /* LSexpr0() does the work of both LSexpr() and LLiteral();
2371    special says whether to interpret lists specially */
LSexpr0(Lake * lake,int listhow)2372 static inline LObject *LSexpr0(Lake *lake, int listhow)
2373 {
2374   LObject *obj, *head;
2375   int i, quote;
2376   const char *tok;
2377 
2378   if ((tok = LakeNextToken(lake, &quote)) == NULL) {
2379     return Lnil;
2380   }
2381   if (quote == '\0' && *tok == '(') {
2382     obj = LNew(LLIST, NULL);
2383     if(listhow == LIST_LITERAL) {
2384       while (LakeMore(lake)) {
2385 	obj->cell.p = (void*) LListAppend((LList*)(obj->cell.p),
2386 					  LSexpr0(lake, LIST_LITERAL));
2387       }
2388     } else if (LakeMore(lake)) {
2389       /* if we have a non-empty list ... */
2390       /* ... get the first element and see if it's a function name */
2391       head = LEvalSexpr(lake);
2392       obj->cell.p = (void*) LListAppend(LLISTVAL(obj), head);
2393       if (funcfromobj(head, &i)) {
2394 	/* It's a function name.  Enter the function as the first element
2395 	   of our list, and then call the function in parse mode to
2396 	   construct the rest of the list (arguments to the function) */
2397 	if (head->type == LSYMBOL) {
2398 	  /* Builtin function or defun */
2399 	  LFree(head);
2400 	  LLISTVAL(obj)->car = head = LNew(LFUNC, &i);
2401 	} else {
2402 	  /* anonymous lambda expression */
2403 	  LLISTVAL(obj)->cdr = LListNew();
2404 	  LLISTVAL(obj)->cdr->car = LLISTVAL(obj)->car;
2405 	  LLISTVAL(obj)->car = head = LNew(LFUNC, &i);
2406 	}
2407 
2408 	if ( (*functable[i].fptr)(lake, LLISTVAL(obj)) == Lnil ) {
2409 	  LFree(obj);
2410 	  obj = Lnil;
2411 	}
2412       } else {
2413 	/* It's not a function name.  Probably this part will only
2414 	   be called in error, because plain lists should always be
2415 	   quoted.  This should probably be replaced by more robust
2416 	   error detection and recovery code.  For now, just parse
2417 	   as a plain list.  LEval() will emit an error message if
2418 	   this list is ever evaluated. */
2419 	if(listhow == LIST_EVAL)
2420 	  OOGLSyntax(lake->streamin,
2421 		     "Reading \"%s\": call to unknown function \"%s\"",
2422 		     LakeName(lake), LSummarize(head));
2423 	while (LakeMore(lake)) {
2424 	  obj->cell.p = (void*) LListAppend(LLISTVAL(obj),
2425 					    LSexpr0(lake, listhow));
2426 	}
2427       }
2428     }
2429     tok = LakeNextToken(lake, &quote);
2430   } else {
2431     obj = LNew(quote == '\0' ? LSYMBOL : LSTRING, NULL);
2432     obj->cell.p = strdup(tok);
2433   }
2434   return obj;
2435 }
2436 
LEval(LObject * obj)2437 LObject *LEval(LObject *obj)
2438 {
2439   LObject *ans;
2440   LList *list, *args;
2441   LInterest *interest;
2442   LFunction *fentry;
2443 
2444   /* Lists are function calls, symbols may have values bound to them,
2445    * everything else evaluates to itself.
2446    */
2447   if (obj->type == LSYMBOL) {
2448     LObject *val;
2449 
2450     val = namespace_get(lambda_namespace, LSYMBOLVAL(obj));
2451     if (val != NULL) {
2452       return val;
2453     }
2454 
2455     val = namespace_get(setq_namespace, LSYMBOLVAL(obj));
2456     if (val != NULL) {
2457       return val;
2458     }
2459   }
2460 
2461   if (obj->type != LLIST) {
2462     LRefIncr(obj);
2463     return obj;
2464   }
2465 
2466   list = LLISTVAL(obj);
2467 
2468   /* the empty list evaluates to itself */
2469   if (list == NULL || list->car == NULL) {
2470     return Lnil;
2471   }
2472 
2473   /* a nonempty list corresponds to a function call;
2474      the list's value is the value returned by the function */
2475   if (list->car->type == LFUNC) {
2476     fentry = &functable[LFUNCVAL(list->car)];
2477 
2478 #if 0
2479     /* deal with any interests in the function first */
2480     if ((interest=fentry->interested) != NULL) {
2481       args = list->cdr;
2482       while (interest) {
2483 	if (FilterArgMatch(interest->filter, args)) {
2484 	  InterestOutput(fentry->name, args, interest);
2485 	}
2486 	interest = interest->next;
2487       }
2488     }
2489 #endif
2490 
2491     /* then call the function */
2492     ans = fentry->fptr(NULL, list);
2493 
2494     /* deal with any interests in the function after calling the
2495      * function; otherwise the arguments are in an unevaluated state.
2496      */
2497     if ((interest=fentry->interested) != NULL) {
2498       args = list->cdr;
2499       while (interest) {
2500 	if (FilterArgMatch(interest->filter, args)) {
2501 	  InterestOutput(fentry->name, args, interest);
2502 	}
2503 	interest = interest->next;
2504       }
2505     }
2506 
2507     return ans;
2508   } else {
2509     OOGLError(0, "lisp error: call to unknown function %s",
2510 	      LSummarize(list->car));
2511     return Lnil;
2512   }
2513 }
2514 
LListAppend(LList * list,LObject * obj)2515 LList *LListAppend(LList *list, LObject *obj)
2516 {
2517   LList *l, *new = LListNew();
2518 
2519   new->car = obj;
2520   if ((l = list) != NULL) {
2521     while (l->cdr) l = l->cdr;
2522     l->cdr = new;
2523     return list;
2524   }
2525   return new;
2526 }
2527 
LListLength(LList * list)2528 int LListLength(LList *list)
2529 {
2530   int n=0;
2531   while (list) {
2532     ++n;
2533     list = list->cdr;
2534   }
2535   return n;
2536 }
2537 
LListEntry(LList * list,int n)2538 LObject *LListEntry(LList *list, int n)
2539 {
2540   if (n < 0) n = LListLength(list) + 1 + n;
2541   while (list && --n) list = list->cdr;
2542   if (list) return list->car;
2543   else return NULL;
2544 }
2545 
2546 LDEFINE(car, LLOBJECT,
2547 	"(car LIST)\n"
2548 	"returns the first element of LIST.")
2549 {
2550   LList *list;
2551   LDECLARE(("car", LBEGIN,
2552 	    LLIST, &list,
2553 	    LEND));
2554   if (list && list->car) {
2555     return LRefIncr(list->car);
2556   }
2557   return Lnil;
2558 }
2559 
2560 LDEFINE(cdr, LLOBJECT,
2561 	"(cdr LIST)\n"
2562 	"returns the list obtained by removing the first element of LIST.")
2563 {
2564   LList *list;
2565 
2566   LDECLARE(("cdr", LBEGIN,
2567 	    LLIST, &list,
2568 	    LEND));
2569 
2570   if (list && list->cdr) {
2571     LList *copy = LListShallowCopy(list->cdr);
2572     return LNew(LLIST, &copy);
2573   }
2574   return Lnil;
2575 }
2576 
2577 LDEFINE(cons, LLOBJECT,
2578 	"(cons EXPR LIST)\n"
2579 	"returns the list obtained by adding EXPR as first element of LIST.")
2580 {
2581   LObject *llist;
2582   LObject *car;
2583   LList *cdr;
2584 
2585   LDECLARE(("cons", LBEGIN,
2586 	    LLOBJECT, &car,
2587 	    LLIST, &cdr,
2588 	    LEND));
2589 
2590   llist = LNew(LLIST, NULL);
2591   llist->cell.p = LListNew();
2592   LLISTVAL(llist)->car = LRefIncr(car);
2593   LLISTVAL(llist)->cdr = LListShallowCopy(cdr);
2594 
2595   return llist;
2596 }
2597 
2598 /*
2599  * function definition implementation
2600  */
LDefun(const char * name,LObjectFunc func,const char * help)2601 bool LDefun(const char *name, LObjectFunc func, const char *help)
2602 {
2603   int index = funcindex(name);
2604   LFunction *lfunction;
2605 
2606   if (index >= 0) {
2607     lfunction = VVINDEX(funcvvec, LFunction, index);
2608     if (lfunction->lambda == NULL) {
2609       VARARRAY(builtin, char, strlen(name)+sizeof("-builtin--"));
2610       OOGLWarn("Warning: replacing existing definition of builtin function\n"
2611 	       "                       \"%s\"\n"
2612 	       "The old definition is still available under the new name\n"
2613 	       "               \"-builtin-%s-\"",
2614 	       name, name);
2615       sprintf(builtin, "-builtin-%s-", name);
2616       LDefun(builtin, lfunction->fptr, lfunction->help);
2617     }
2618     lfunction = VVINDEX(funcvvec, LFunction, index);
2619     if (lfunction->lambda) {
2620       LFree(lfunction->lambda);
2621     }
2622     if (lfunction->help) {
2623       free(lfunction->help);
2624     }
2625   } else {
2626     index = VVCOUNT(funcvvec)++;
2627     lfunction = VVINDEX(funcvvec, LFunction, index);
2628     lfunction->name = strdup(name);
2629   }
2630   lfunction->fptr = func;
2631   lfunction->help = NULL;
2632   lfunction->lambda = NULL;
2633   lfunction->interested = NULL;
2634   fsa_install(func_fsa, lfunction->name, (void *)(long)index);
2635   if (help) {
2636     lfunction->help = strdup(help);
2637     LHelpDef(lfunction->name, lfunction->help);
2638   }
2639   return true;
2640 }
2641 
2642 /* Function is called in one of three modes:
2643    lake != NULL, args != NULL: parse mode
2644    In this mode, upon entry args is a list containing one element,
2645    the function object itself.  We parse arguments from lake,
2646    appending them to the args list.  We return Lt if the parsing was
2647    successful, Lnil if not.
2648    lake == NULL: evaluate mode
2649    In this mode, upon entry args is a list containing the arguments
2650    to the function.  We return the function's value on the arguments.
2651 */
2652 
funcindex(const char * name)2653 static int funcindex(const char *name)
2654 {
2655   return (int)(long)fsa_parse( func_fsa, name );
2656 }
2657 
2658 /*
2659  * The LDECLARE() macro calls this function.
2660  */
LParseArgs(const char * name,Lake * lake,LList * args,...)2661 LParseResult LParseArgs(const char *name, Lake *lake, LList *args, ...)
2662 {
2663   bool moreargspecs = true, literal = false;
2664   int argsgot = 0, argsrequired= -1, argspecs = 0;
2665   LType *argclass;
2666   va_list a_list;
2667 
2668   va_start(a_list, args);
2669 
2670   if (lake == NULL) {
2671     LParseResult val = AssignArgs(name, args->cdr, a_list);
2672     va_end(a_list);
2673     return val;
2674   }
2675 
2676   while (moreargspecs) {
2677     argclass=va_arg(a_list, LType *);
2678     if (argclass->size < 0) {
2679       if (argclass == LEND) {
2680 	moreargspecs = false;
2681       } else if (argclass == LOPTIONAL) {
2682 	argsrequired = argspecs;
2683       } else if (argclass == LHOLD) {
2684 	/* "LHOLD" has no meaning during the parsing stage */
2685       } else if (argclass == LLITERAL) {
2686 	/* literal affects the way an argument is parsed (as well as
2687 	   implying "hold" in the assignment stage). It should only be
2688 	   used on LLOBJECT or LLIST.  It means: "parse the argument
2689 	   literally". In non-literal parsing, lists are treated as
2690 	   function calls and the function is called to parse the
2691 	   arguments. In literal parsing, we don't treat lists as
2692 	   function calls. Just parse them as lists. */
2693 	literal = true;
2694       } else if (argclass == LARRAY) {
2695 	/* special case for this because it takes 3 args: the base type,
2696 	   the array itself, and a count */
2697 	(void)va_arg(a_list, LType *);
2698 	(void)va_arg(a_list, void *);
2699 	(void)va_arg(a_list, int *);
2700 
2701 	++argspecs;
2702 	if (LakeMore(lake)) {
2703 	  LListAppend(args, LSexpr(lake));
2704 	  ++argsgot;
2705 	}
2706       } else if (argclass == LVARARRAY) {
2707 	/* special case for this because it takes 3 args: the base type,
2708 	   the array-pointer itself, and a count */
2709 	(void)va_arg(a_list, LType *);
2710 	(void)va_arg(a_list, void **);
2711 	(void)va_arg(a_list, int *);
2712 
2713 	++argspecs;
2714 	if (LakeMore(lake)) {
2715 	  LListAppend(args, LSexpr(lake));
2716 	  ++argsgot;
2717 	}
2718       } else if(argclass == LREST) {
2719 	/*
2720 	 * Gather up any remaining arguments into an LList.
2721 	 * If the caller provides a NULL pointer, discard them;
2722 	 * otherwise store the list there.  Note that we yield an LList,
2723 	 * not an LLIST-typed LObject.
2724 	 */
2725 	LList **restp = va_arg(a_list, LList **);
2726 
2727 	(void)restp;
2728 
2729 	while(LakeMore(lake)) {
2730 	  /* Stash args for AssignArgs to grab */
2731 	  LListAppend(args, literal ? LLiteral(lake) : LSexpr(lake));
2732 	}
2733 	moreargspecs = false;
2734       }
2735     } else if(argclass == LLAKE) {
2736       (void)va_arg(a_list, Lake **);
2737       LListAppend(args, LTOOBJ(LLAKE)(&lake));
2738     } else {
2739       ++argspecs;
2740       (void)va_arg(a_list, void *);
2741       if (LakeMore(lake)) {
2742 	LObject *arg;
2743 
2744 	if (literal) {
2745 	  /* literal should only be used on LLOBJECT or LLIST
2746 	     types, both of which use the LSexpr() parse method; in
2747 	     the literal case, we use LLiteral() instead. */
2748 	  arg = LLiteral(lake);
2749 	  literal = false;
2750 	} else {
2751 	  /* ParseArg() invokes SExpr() on S-expr and the
2752 	   * type-specific parser otherwise.
2753 	   */
2754 	  arg = ParseArg(argclass, lake);
2755 	}
2756 	LListAppend(args, arg);
2757 	++argsgot;
2758       }
2759     }
2760   }
2761   if (argsrequired < 0) {
2762     argsrequired = argspecs;
2763   }
2764   va_end(a_list);
2765   if (argsgot < argsrequired) {
2766     OOGLSyntax(lake->streamin,
2767 	       "Reading from \"%s\": %s requires %d args, got %d",
2768 	       PoolName(POOL(lake)),name,argsrequired,argsgot);
2769     return LPARSE_BAD;
2770   }
2771   if (LakeMore(lake)) {
2772     OOGLSyntax(lake->streamin,
2773 	       "In \"%s\": %s: ignoring additional arguments (expected %1d)\n",
2774 	       PoolName((Pool *)(lake->river)), name, argsgot);
2775     while (LakeMore(lake)) {
2776       LFree(LSexpr(lake));
2777     }
2778   }
2779   return LPARSE_GOOD;
2780 }
2781 
obj2array(LObject * obj,LType * type,char * x,int * n,bool hold)2782 static bool obj2array(LObject *obj, LType *type, char *x, int *n, bool hold)
2783 {
2784   int max= abs(*n);
2785   LList *list;
2786   char *tmp;
2787 
2788   *n = 0;
2789 
2790   /* interprete the nil object as an empty list */
2791   if ((obj == Lnil) || (stringfromobj(obj, &tmp) && strcmp(tmp, "nil") == 0)) {
2792     return true;
2793   }
2794 
2795   list = LLISTVAL(obj);
2796   if (obj->type != LLIST) {
2797     return false;
2798   }
2799   if (list == NULL || list->car == NULL) {
2800     return true;
2801   }
2802   if (list->car->type == LLAKE) {
2803     list = list->cdr;
2804   }
2805   while (list && list->car && *n < max) {
2806     LObject *obj = hold ? LRefIncr(list->car) : LEval(list->car);
2807     if (!LFROMOBJ(type)(obj, (void*)(x + (*n)*LSIZE(type)))) {
2808       LFree(obj);
2809       return false;
2810     }
2811     LFree(obj);
2812     (*n)++;
2813     list = list->cdr;
2814   }
2815   if (*n == max && list) {
2816     return false;
2817   }
2818   return true;
2819 }
2820 
2821 /* variable length array */
obj2vararray(LObject * obj,LType * type,char ** x,int * n,bool hold)2822 static bool obj2vararray(LObject *obj, LType *type, char **x, int *n, bool hold)
2823 {
2824   LList *list;
2825   char *tmp;
2826 
2827   /* interprete the nil object as an empty list */
2828   if ((obj == Lnil) || (stringfromobj(obj, &tmp) && strcmp(tmp, "nil") == 0)) {
2829     if (*x) {
2830       OOGLFree(*x);
2831     }
2832     *x = NULL;
2833     *n = 0;
2834     return true;
2835   }
2836 
2837   list = LLISTVAL(obj);
2838   if (obj->type != LLIST) {
2839     if (*x) {
2840       OOGLFree(*x);
2841     }
2842     *x = NULL;
2843     *n = 0;
2844     return false;
2845   }
2846   if (list == NULL || list->car == NULL) {
2847     if (*x) {
2848       OOGLFree(*x);
2849     }
2850     *x = NULL;
2851     return true;
2852   }
2853   if (list->car->type == LLAKE) {
2854     list = list->cdr;
2855   }
2856   *n = LListLength(list);
2857   *x = OOGLRenewNE(char, *x, (*n)*LSIZE(type), "C-lisp vararray");
2858   *n = 0;
2859   while (list && list->car) {
2860     LObject *obj = hold ? LRefIncr(list->car) : LEval(list->car);
2861     if (!LFROMOBJ(type)(list->car, (void * )((*x) + (*n)*LSIZE(type)))) {
2862       LFree(obj);
2863       return false;
2864     }
2865     LFree(obj);
2866     (*n)++;
2867     list = list->cdr;
2868   }
2869   return true;
2870 }
2871 
LMakeArray(LType * basetype,char * array,int count)2872 LObject *LMakeArray(LType *basetype, char *array, int count)
2873 {
2874   int i;
2875   LList *list = NULL;
2876   LObject *obj;
2877 
2878   for (i=0; i<count; ++i) {
2879     obj = LTOOBJ(basetype)((void*)(array + i*LSIZE(basetype)));
2880     list = LListAppend(list, obj);
2881   }
2882   return LNew(LLIST, &list);
2883 }
2884 
2885 /* LParseArgs() MUST NOT evaluate the arguments, this is left to
2886    AssignArgs().
2887  */
AssignArgs(const char * name,LList * args,va_list a_list)2888 static LParseResult AssignArgs(const char *name, LList *args, va_list a_list)
2889 {
2890   bool moreargspecs = true, hold = false, convok;
2891   int argsgot = 0, argsrequired= -1, argspecs = 0;
2892   Lake *lake = NULL;
2893   LObject *arg;
2894   LType *argtype;
2895 
2896   while (moreargspecs) {
2897     if (args && args->car && lakefromobj(args->car, &lake)) {
2898       args = args->cdr;
2899     }
2900     argtype=va_arg(a_list, LType *);
2901     if (argtype->size < 0) {
2902       if (argtype == LEND) {
2903 	moreargspecs = false;
2904       } else if (argtype == LOPTIONAL) {
2905 	argsrequired = argspecs;
2906       } else if (argtype == LHOLD) {
2907 	hold = true; /* do not evaluate the arguments */
2908       } else if (argtype == LLITERAL) {
2909 	/* in the assignment stage, literal means the same as hold */
2910 	hold = true;
2911       } else if (argtype == LARRAY) {
2912 	/* get the base type of the array */
2913 	argtype=va_arg(a_list, LType *);
2914 	++argspecs;
2915 	if (args) {
2916 	  void *array = va_arg(a_list, void*);
2917 	  int *count = va_arg(a_list, int*);
2918 	  int origcount = abs(*count);
2919 	  if (hold) {
2920 	    arg = LRefIncr(args->car);
2921 	  } else {
2922 	    arg = LEval(args->car);
2923 	  }
2924 	  ++argsgot;
2925 	  convok = obj2array(arg, argtype, array, count, hold);
2926 	  if (!convok) {
2927 	    OOGLError(0, "%s: array of at most %1d %ss expected in\n"
2928 		      "arg position %1d (got %s)\n",
2929 		      name, origcount, argtype->name, argsgot,
2930 		      LSummarize(arg));
2931 	  }
2932 	  args = args->cdr;
2933 	} else {
2934 	  (void)va_arg(a_list, void *);
2935 	  (void)va_arg(a_list, void *);
2936 	}
2937 	hold = false;
2938       } else if (argtype == LVARARRAY) {
2939 	/* get the base type of the array */
2940 	argtype=va_arg(a_list, LType *);
2941 	++argspecs;
2942 	if (args) {
2943 	  void *arrayp = va_arg(a_list, void*);
2944 	  int *countp = va_arg(a_list, int*);
2945 
2946 	  if (hold) {
2947 	    arg = LRefIncr(args->car);
2948 	  } else {
2949 	    arg = LEval(args->car);
2950 	  }
2951 	  ++argsgot;
2952 	  convok = obj2vararray(arg, argtype, arrayp, countp, hold);
2953 	  if (!convok) {
2954 	    OOGLError(0,
2955 		      "%s: variable length array conversion failed "
2956 		      "after converting %1d %ss in\n"
2957 		      "arg position %1d (got %s)\n",
2958 		      name, *countp, argtype->name,
2959 		      argsgot, LSummarize(arg));
2960 	  }
2961 	  args = args->cdr;
2962 	} else {
2963 	  (void)va_arg(a_list, void *);
2964 
2965 	  (void)va_arg(a_list, void *);
2966 	}
2967 	hold = false;
2968       } else if(argtype == LREST) {
2969 	LList **restp = va_arg(a_list, LList **);
2970 	if(restp) {
2971 	  *restp = args;
2972 	}
2973 	if (!hold) {
2974 	  /* Evaluate the arguments if !hold */
2975 	  while (args) {
2976 	    LObject *car = args->car;
2977 	    args->car = LEval(car);
2978 	    LFree(car);
2979 	    args = args->cdr;
2980 	  }
2981 	}
2982 	moreargspecs = false;
2983 	args = NULL; /* Don't complain of excess args */
2984       }
2985     } else if (argtype == LLAKE) {
2986       if (lake) {
2987 	*va_arg(a_list, Lake **) = lake;
2988       } else {
2989 	OOGLError(0, "%s: internal lake assignment out of whack.", name);
2990 	return LASSIGN_BAD;
2991       }
2992     } else {
2993       ++argspecs;
2994       if (args) {
2995 	if (!hold) {
2996 	  /* Evaluate the object and replace it in the argument list
2997 	   * such that the caller can free the result. The original
2998 	   * S-expr is free-ed here.
2999 	   */
3000 	  arg = LEval(args->car);
3001 	  LFree(args->car);
3002 	  args->car = arg;
3003 	}
3004 	++argsgot;
3005 	convok = LFROMOBJ(argtype)(args->car, va_arg(a_list, void *));
3006 	if (!convok) {
3007 	  OOGLError(0,"%s: %s expected in arg position %1d (got %s)\n",
3008 		    name, LNAME(argtype), argsgot, LSummarize(args->car));
3009 	  return LASSIGN_BAD;
3010 	}
3011 	args = args->cdr;
3012       } else {
3013 	(void)va_arg(a_list, void *);
3014       }
3015       hold = false;
3016     }
3017   }
3018   if (argsrequired < 0) {
3019     argsrequired = argspecs;
3020   }
3021   if (argsgot < argsrequired) {
3022     OOGLError(0, "%s: internal argument list deficit; require %1d, got %1d",
3023 	      name, argsrequired, argsgot);
3024     return LASSIGN_BAD;
3025   }
3026   if (args) {
3027     OOGLError(1, "%s: internal argument list excess", name);
3028     return LASSIGN_BAD;
3029   }
3030   return LASSIGN_GOOD;
3031 }
3032 
LArgClassValid(LType * type)3033 bool LArgClassValid(LType *type)
3034 {
3035   return (type->magic == LTypeMagic);
3036 }
3037 
LEvalFunc(const char * name,...)3038 LObject *LEvalFunc(const char *name, ...)
3039 {
3040   va_list a_list;
3041   LList *list, *tail, *rest = NULL;
3042   LObject *obj, *val;
3043   int i;
3044   LType *a;
3045   LCell cell;
3046 
3047   if ((i = funcindex(name)) != REJECT) {
3048     list = LListAppend(NULL, LNew(LFUNC, &i));
3049   } else {
3050     list = LListAppend(NULL, LNew(LSYMBOL, &name));
3051   }
3052   tail = list;
3053 
3054   va_start(a_list, name);
3055   while ((a = va_arg(a_list, LType *)) != LEND) {
3056     if (a == LHOLD || a == LLITERAL || a == LOPTIONAL) {
3057       /* do nothing */
3058     } else if (a == LARRAY || a == LVARARRAY) {
3059       LType *basetype=va_arg(a_list, LType *);
3060       void *array = va_arg(a_list, void *);
3061       int count = abs(va_arg(a_list, int));
3062 
3063       tail->cdr = LListAppend(NULL, LMakeArray(basetype, array, count));
3064       tail = tail->cdr;
3065     } else if (a == LREST) {
3066       /* This is a special case: the argument list is terminated, and
3067        * "rest" is treated as the tail of the argument list.
3068        */
3069       LPULL(LLIST)(&a_list, &rest);
3070 
3071       tail->cdr = rest;
3072       if (va_arg(a_list, LType *) != LEND) {
3073 	OOGLError(0, "LEvalFunc%(s): Error: excess arguments after LREST.",
3074 		  name);
3075 	LListFree(list);
3076 	return Lnil;
3077       }
3078       break;
3079     } else {
3080       LPULL(a)(&a_list, &cell);
3081       tail->cdr = LListAppend(NULL, LTOOBJ(a)(&cell));
3082       tail = tail->cdr;
3083     }
3084   }
3085   /* This makes a copy of "list", slow but safe. */
3086   obj = LNew(LLIST, &list);
3087   val = LEval(obj);
3088   tail->cdr = NULL; /* Do not delete rest! */
3089   LFree(obj);
3090   return val;
3091 }
3092 
filterfromobj(LObject * obj,LFilter ** x)3093 static bool filterfromobj(LObject *obj, LFilter **x)
3094 {
3095   if (obj->type != LFILTER) return false;
3096   *x = LFILTERVAL(obj);
3097   return true;
3098 }
3099 
filter2obj(LFilter ** x)3100 static LObject *filter2obj(LFilter **x)
3101 {
3102   LFilter *copy = OOGLNew(LFilter);
3103   copy->flag = (*x)->flag;
3104   copy->value = (*x)->value ? LCopy((*x)->value) : NULL;
3105   return LNew( LFILTER, &copy );
3106 }
3107 
filterfree(LFilter ** x)3108 static void filterfree(LFilter **x)
3109 {
3110   if (*x) {
3111     if ((*x)->value) LFree((*x)->value);
3112     OOGLFree(*x);
3113   }
3114 }
3115 
filterwrite(FILE * fp,LFilter ** x)3116 static void filterwrite(FILE *fp, LFilter **x)
3117 {
3118   switch ((*x)->flag) {
3119   case VAL:
3120     fprintf(fp, "filter[VAL,");
3121     LWrite(fp, (*x)->value);
3122     fprintf(fp, "]");
3123     break;
3124   case ANY:
3125     fprintf(fp, "filter[ANY]");
3126     break;
3127   case NIL:
3128     fprintf(fp, "filter[NIL]");
3129     break;
3130   default:
3131     fprintf(fp, "filter[???");
3132     break;
3133   }
3134 }
3135 
3136 LType LFilterp = {
3137   "filter",
3138   sizeof(LFilter *),
3139   filterfromobj,
3140   filter2obj,
3141   filterfree,
3142   filterwrite,
3143   NULL,
3144   NULL,
3145   LSexpr,
3146   LTypeMagic
3147 };
3148 
3149 LDEFINE(interest, LVOID,
3150 	"(interest (COMMAND [args]))\n\
3151 \n\
3152 	Allows you to express interest in a command.  When geomview\n\
3153 	executes that command in the future it will echo it to the\n\
3154 	communication pool from which the interest command came.\n\
3155 	COMMAND can be any command.  Args specify restrictions on the\n\
3156 	values of the arguments; if args are present in the interest\n\
3157 	command, geomview will only echo calls to the command in which\n\
3158 	the arguments match those given in the interest command.  Two\n\
3159 	special argument values may appear in the argument list.  \"*\"\n\
3160 	matches any value. \"nil\" matches any value but supresses the\n\
3161 	reporting of that value; its value is reported as \"nil\".\n\
3162 \n\
3163 	The purpose of the interest command is to allow external\n\
3164 	modules to find out about things happening inside geomview.\n\
3165 	For example, a module interested in knowing when a geom called\n\
3166 	\"foo\" is deleted could say \"(interest (delete foo))\" and would\n\
3167 	receive the string \"(delete foo)\" when foo is deleted.\n\
3168 \n\
3169 	Picking is a special case of this.  For most modules\n\
3170 	interested in pick events the command \"(interest (pick\n\
3171 	world))\" is sufficient.  This causes geomview to send a string\n\
3172 	of the form \"(pick world ...)\" every time a pick event (right\n\
3173 	mouse double click).  See the \"pick\" command for details.")
3174 {
3175   Lake *calhoun;
3176   LList *call;
3177 
3178   LDECLARE(("interest", LBEGIN,
3179 	    LLAKE, &calhoun,
3180 	    LLITERAL, LLIST, &call,
3181 	    LEND));
3182 
3183   return do_interest(calhoun, call, "interest");
3184 }
3185 
3186 LDEFINE(uninterest, LVOID,
3187 	"(uninterest (COMMAND [args]))\n\
3188 	Undoes the effect of an \"interest\" command.  (COMMAND [args]) must\n\
3189 	be identical to those used in the \"interest\" command.")
3190 {
3191   Lake *calhoun;
3192   LList *call;
3193 
3194   LDECLARE(("uninterest", LBEGIN,
3195 	    LLAKE, &calhoun,
3196 	    LLITERAL, LLIST, &call,
3197 	    LEND));
3198 
3199   return do_interest(calhoun, call, "uninterest");
3200 }
3201 
3202 LDEFINE(time_interests, LVOID,
3203 	"(time-interests deltatime initial prefix [suffix])\n\
3204 	Indicates that all interest-related messages, when separated by at\n\
3205 	least \"deltatime\" seconds of real time, should be preceded by\n\
3206 	the string ``prefix'' and followed by ``suffix''; the first message\n\
3207 	is preceded by ``initial''.  All three are printf format strings,\n\
3208 	whose argument is the current clock time (in seconds) on that stream.\n\
3209 	A \"deltatime\" of zero timestamps every message.  Typical usage:\n\
3210 	(time-interests .1 \"(set-clock %g)\" \"(sleep-until %g)\")  or\n\
3211 	(time-interests .1 \"(set-clock %g)\"\n\
3212 		\"(sleep-until %g) (progn (set-clock %g)\" \")\")    or\n\
3213 	(time-interests .1 \"(set-clock %g)\"\n\
3214 			   \"(if (> 0 (sleep-until %g)) (\" \"))\".")
3215 {
3216   Lake *l;
3217   float dt;
3218   char *initial = NULL, *prefix = NULL, *suffix = NULL;
3219   LDECLARE(("time-interests", LBEGIN,
3220 	    LLAKE, &l,
3221 	    LOPTIONAL, LFLOAT, &dt,
3222 	    LSTRING, &initial,
3223 	    LSTRING, &prefix,
3224 	    LSTRING, &suffix,
3225 	    LEND));
3226   if(l->timing_interests) {
3227     l->timing_interests = 0;
3228     if(l->initial) free((char *)l->initial);
3229     if(l->prefix) free((char *)l->prefix);
3230     if(l->suffix) free((char *)l->suffix);
3231   }
3232   if(initial) {
3233     l->timing_interests = 1;
3234     l->initial = strdup(initial);
3235     l->prefix = prefix ? strdup(prefix) : NULL;
3236     l->suffix = suffix ? strdup(suffix) : NULL;
3237     l->deltatime = dt;
3238     l->nexttime = -1e10;
3239   }
3240   return Lt;
3241 }
3242 
do_interest(Lake * lake,LList * call,char * action)3243 static LObject *do_interest(Lake *lake, LList *call, char *action)
3244 {
3245   int i;
3246   LList *filter, *cargs;
3247   char *command;
3248   LInterest *new;
3249 
3250   if (!call || !call->car) {
3251     fprintf(stderr,"%s: COMMAND required.\n", action);
3252     return Lnil;
3253   }
3254   if (!symbolfromobj(call->car, &command)) {
3255     fprintf(stderr, "%s: COMMAND must be a symbol (got `%s')\n",
3256 	    action, LSummarize(call->car));
3257     return Lnil;
3258   }
3259 
3260   /* any remaining args are the command's args */
3261   cargs = call->cdr;
3262 
3263   if ( (i=funcindex(command)) < 0 ) {
3264     fprintf(stderr, "%s: no such command \"%s\"\n", action,command);
3265     return Lnil;
3266   }
3267 
3268   filter = FilterList(cargs);
3269 
3270   if (strcmp(action, "interest")==0) {
3271     new = NewInterest();
3272     new->lake = lake;
3273     new->filter = filter;
3274     AppendInterest(&(functable[i].interested),  new);
3275   } else {
3276     RemoveInterests(&(functable[i].interested), lake, 1, filter);
3277     LListFree(filter);
3278   }
3279   return Lt;
3280 }
3281 
RemoveInterests(LInterest ** interest,Lake * lake,int usefilter,LList * filter)3282 static void RemoveInterests(LInterest **interest, Lake *lake,
3283 			    int usefilter, LList *filter)
3284 {
3285   LInterest *rest;
3286 
3287   while (*interest) {
3288     if (InterestMatch(*interest, lake, usefilter, filter)) {
3289       rest = (*interest)->next;
3290       DeleteInterest(*interest);
3291       *interest = rest;
3292     } else {
3293       interest = &((*interest)->next);
3294     }
3295   }
3296 }
3297 
RemoveLakeInterests(Lake * lake)3298 void RemoveLakeInterests(Lake *lake)
3299 {
3300   int i;
3301 
3302   for (i=0; i<VVCOUNT(funcvvec); ++i) {
3303     if (functable[i].interested)
3304       RemoveInterests(&(functable[i].interested), lake, 0, NULL);
3305   }
3306 }
3307 
3308 
InterestMatch(LInterest * interest,Lake * lake,bool usefilter,LList * filter)3309 static bool InterestMatch(LInterest *interest, Lake *lake,
3310 			  bool usefilter, LList *filter)
3311 {
3312   LList *ifilter;
3313 
3314   if (interest->lake != lake) return false;
3315   if (!usefilter) return true;
3316   ifilter = interest->filter;
3317   while (filter) {
3318     if (!ifilter) return false;
3319     if (!FilterMatch(LFILTERVAL(filter->car),
3320 		     LFILTERVAL(ifilter->car))) return false;
3321     filter = filter->cdr;
3322     ifilter = ifilter->cdr;
3323   }
3324   if (ifilter) return false;
3325   return true;
3326 }
3327 
FilterMatch(LFilter * f1,LFilter * f2)3328 static bool FilterMatch(LFilter *f1, LFilter *f2)
3329 {
3330   if (f1 && !f2) return false;
3331   if (f2 && !f1) return false;
3332   if (!f1 && !f2) return true;
3333   if (f1->flag != f2->flag) return false;
3334   switch (f1->flag) {
3335   case ANY:
3336   case NIL:
3337     return true;
3338   case VAL:
3339     if (f1->value->type != f2->value->type) return false;
3340     return LMATCH(f1->value->type)( &(f1->value->cell), &(f2->value->cell) );
3341   default:
3342     OOGLError(0,"invalid filter flag value.  Please report this.");
3343     return false;
3344   }
3345 }
3346 
DeleteInterest(LInterest * interest)3347 static void DeleteInterest(LInterest *interest)
3348 {
3349   if (interest) {
3350     if (interest->filter) LListFree(interest->filter);
3351     OOGLFree(interest);
3352   }
3353 }
3354 
NewInterest()3355 static LInterest *NewInterest()
3356 {
3357   LInterest *new = OOGLNewE(LInterest, "interest");
3358   new->filter = NULL;
3359   new->next = NULL;
3360   return new;
3361 }
3362 
AppendInterest(LInterest ** head,LInterest * new)3363 static void AppendInterest(LInterest **head, LInterest *new)
3364 {
3365   if (!head) {
3366     OOGLError(0,"Null head pointer in AppendInterest");
3367     return;
3368   }
3369   while (*head) head = &((*head)->next);
3370   *head = new;
3371 }
3372 
FilterList(LList * args)3373 static LList *FilterList(LList *args)
3374 {
3375   LList *filterlist;
3376   LFilter *filter;
3377 
3378   if (!args) return NULL;
3379   filterlist = NULL;
3380   while (args) {
3381     if (!args->car) {
3382       OOGLError(1,"FilterList internal error");
3383       return NULL;
3384     }
3385     if ((strcmp(LSTRINGVAL(args->car),"*")==0) || (args->car==Lt)) {
3386       filterlist = LListAppend(filterlist, LRefIncr(LFAny));
3387     } else if ((strcmp(LSTRINGVAL(args->car),"nil")==0) || (args->car==Lnil) ) {
3388       filterlist = LListAppend(filterlist, LRefIncr(LFNil));
3389     } else {
3390       filter = OOGLNew(LFilter);
3391       filter->flag = VAL;
3392       filter->value = LRefIncr(args->car);
3393       filterlist = LListAppend(filterlist, LNew(LFILTER, &filter));
3394     }
3395     args = args->cdr;
3396   }
3397   return filterlist;
3398 }
3399 
FilterArgMatch(LList * filter,LList * args)3400 static bool FilterArgMatch(LList *filter,  LList *args)
3401 {
3402   int filterflag;
3403   LObject *filterobj;
3404   LCell filterval, argval;
3405 
3406   while (args) {
3407 
3408     if (filter) {
3409       filterflag = LFILTERVAL(filter->car)->flag;
3410       filterobj = LFILTERVAL(filter->car)->value;
3411       filter=filter->cdr;
3412     } else
3413       filterflag = ANY;
3414 
3415     switch (filterflag) {
3416     case VAL:
3417       LFROMOBJ(args->car->type)(args->car, &argval);
3418       LFROMOBJ(args->car->type)(filterobj, &filterval);
3419       if (! LMATCH(args->car->type)(&filterval, &argval))
3420 	return false;
3421       break;
3422     case ANY:
3423     case NIL:
3424       break;
3425     }
3426 
3427     args = args->cdr;
3428   }
3429   return true;
3430 }
3431 
InterestOutput(char * name,LList * args,LInterest * interest)3432 static void InterestOutput(char *name, LList *args, LInterest *interest)
3433 {
3434   Lake *lake = interest->lake;
3435   FILE *outf = lake->streamout;
3436   LList *filter = interest->filter;
3437   const char *suffix = NULL;
3438   int filterflag;
3439   float now = 0.0;
3440 
3441   if (!outf) return;
3442 
3443   if(lake->timing_interests &&
3444      (now = PoolTimeAt(POOL(lake), NULL)) > lake->nexttime) {
3445     if(lake->initial) {
3446       fprintf(outf, lake->initial, now,now,now);
3447       free((char *)lake->initial);
3448       lake->initial = NULL;
3449     }
3450     if(lake->prefix)
3451       fprintf(outf, lake->prefix, now,now,now);
3452     suffix = lake->suffix;
3453   }
3454 
3455   fprintf(outf, "(%s", name);
3456 
3457   /* first remove any hidden lake arg */
3458   if (args && args->car && args->car->type == LLAKE)
3459     args = args->cdr;
3460 
3461   while (args) {
3462 
3463     if (filter) {
3464       filterflag = LFILTERVAL(filter->car)->flag;
3465       filter=filter->cdr;
3466     } else
3467       filterflag = ANY;
3468 
3469     switch (filterflag) {
3470     case VAL:
3471     case ANY:
3472       fputc(' ', outf);
3473       LWrite(outf, args->car);
3474       break;
3475     case NIL:
3476       fprintf(outf, " nil");
3477       break;
3478     }
3479 
3480     args = args->cdr;
3481   }
3482   fprintf(outf, ")\n");
3483   if(suffix)
3484     fprintf(outf, suffix, now,now,now);
3485   fflush(outf);
3486 }
3487 
3488 LDEFINE(regtable, LVOID,
3489 	"(regtable) --- shows the registry table")
3490 {
3491   int i;
3492   Lake *outlake;
3493   FILE *outf;
3494   LInterest *interest;
3495   LDECLARE(("regtable", LBEGIN,
3496 	    LLAKE, &outlake,
3497 	    LEND));
3498   outf = outlake->streamout;
3499 
3500   for (i=0; i<VVCOUNT(funcvvec); ++i) {
3501     if ((interest = functable[i].interested) != NULL) {
3502       fprintf(outf, "%s:\n", functable[i].name);
3503       fflush(outf);
3504       while (interest) {
3505 	fprintf(outf, "\t");
3506 	LListWrite(outf, interest->filter);
3507 	fprintf(outf, "\n");
3508 	fflush(outf);
3509 	interest = interest->next;
3510       }
3511       fprintf(outf, "\n");
3512     }
3513   }
3514   return Lt;
3515 }
3516 
3517 
compile(const char * str,pattern * p)3518 static void compile(const char *str, pattern *p)
3519 {
3520   int n;
3521   char *rest, *tail;
3522 
3523   strncpy(p->p0, str, MAXPATLEN-1);
3524   p->p0[MAXPATLEN-1] = '\0';
3525   for(rest = p->p0, n = 0; (tail = strchr(rest, '*')) && n < MAXPAT; n++) {
3526     p->pat[n] = rest;
3527     p->len[n] = tail-rest;
3528     *tail = '\0';
3529     rest = tail+1;
3530   }
3531   p->pat[n] = rest;
3532   p->len[n] = strlen(rest);
3533   p->n = n;
3534 }
3535 
3536 /* Keep the first line unchanged and wrap the remaining lines to 80
3537  * chars with 8 chars indent on the left.
3538  */
print_help_formatted(FILE * outf,const char * message)3539 static void print_help_formatted(FILE *outf, const char *message)
3540 {
3541   char *nl;
3542   int printed, wordlen, nnl;
3543 
3544   /* print the first line unchanged */
3545   if ((nl = strchr(message, '\n')) && message[0]=='(') {
3546     fprintf(outf, "%.*s", (int)(nl - message), message);
3547   }
3548   if (!nl) {
3549     return;
3550   }
3551   message = nl+1;
3552   while (*message) {
3553     fprintf(outf, "\n       ");
3554     printed = 7;
3555     while (*message && printed < 72) {
3556       nnl = 0;
3557       /* keep \n\n as hard line break marker */
3558       while (isspace(*message)) {
3559 	if (*message++ == '\n') {
3560 	  ++nnl;
3561 	}
3562 	if (nnl == 2) {
3563 	  fprintf(outf, "\n       ");
3564 	  printed = 7;
3565 	  /* use \n\n\t\t\t as indentation hint */
3566 	  while (*message == '\t') {
3567 	    fprintf(outf, "        ");
3568 	    printed += 8;
3569 	    message++;
3570 	  }
3571 	  nnl = 0;
3572 	}
3573       }
3574       wordlen = 0;
3575       while (message[wordlen] && !isspace(message[wordlen])) {
3576 	wordlen++;
3577       }
3578       if (printed + wordlen < 72) {
3579 	printed += wordlen+1;
3580 	putc(' ', outf);
3581 	while (wordlen--) {
3582 	  putc((int)*message++, outf);
3583 	}
3584       } else {
3585 	break;
3586       }
3587     }
3588   }
3589   putc('\n', outf);
3590   fflush(outf);
3591 }
3592 
match(const char * str,pattern * p)3593 static bool match(const char *str, pattern *p)
3594 {
3595   int i;
3596   const char *rest;
3597   if(strncmp(str, p->pat[0], p->len[0])) return false;	/* Failed */
3598   rest = str + p->len[0];
3599   for(i = 1; i <= p->n; i++) {
3600     if(p->len[i]) {
3601       if((rest = strstr(rest, p->pat[i])) == NULL) break;
3602       rest += p->len[i];
3603     }
3604   }
3605   return i > p->n && rest && (p->len[p->n] == 0 || *rest == '\0') ? 1 : 0;
3606 }
3607 
LHelpDef(const char * key,const char * message)3608 void LHelpDef(const char *key, const char *message)
3609 {
3610   Help **h = &helps;
3611   Help *new;
3612   int cmp = -1;
3613 
3614   /* insertion sort... */
3615   while (*h && (*h)->key && (cmp = strcmp(key,(*h)->key)) > 0) {
3616     h = &((*h)->next);
3617   }
3618   if (cmp == 0) {
3619     /* replace an existing message */
3620     new = *h;
3621   } else {
3622     new = OOGLNew(Help);
3623     new->key = key;
3624     new->next = *h;
3625     *h = new;
3626   }
3627   new->message = message;
3628 }
3629 
3630 LDEFINE(help, LVOID,
3631 	"(help [COMMAND])\n"
3632 	"\"COMMAND\" may include \"*\"s as wildcards; see also \"??\". "
3633 	"One-line command help; lists names only if multiple commands match.")
3634 {
3635   char *pat = "*";
3636   char *nl;
3637   pattern p;
3638   int seen = 0;
3639   Help *h, *last = NULL;
3640   Lake *brownie;
3641   FILE *outf;
3642 
3643   LDECLARE(("help", LBEGIN,
3644 	    LLAKE, &brownie,
3645 	    LOPTIONAL,
3646 	    LSTRING, &pat,
3647 	    LEND));
3648   if((outf = brownie->streamout) == NULL) outf = stdout;
3649   compile(pat, &p);
3650   for(h=helps; h!=NULL; h=h->next) {
3651     if(match(h->key, &p)) {
3652       if(++seen >= 2) {
3653 	if(seen == 2) fprintf(outf,"%-15s ", last->key);
3654 	fprintf(outf, seen%4 ? "%-15s " : "%s\n", h->key);
3655       }
3656       last = h;
3657     }
3658   }
3659   switch(seen) {
3660   default: if(seen%4) fprintf(outf, "\n"); break;
3661   case 0: fprintf(outf, nomatch, pat); break;
3662   case 1:
3663     nl = strchr(last->message, '\n');
3664     fprintf(outf, "%.*s\n", (int)(nl && last->message[0]=='('
3665 				  ? nl - last->message  : 9999),
3666 	    last->message);
3667     break;
3668   }
3669   fflush(outf);
3670   return Lt;
3671 }
3672 
3673 LDEFINE(morehelp, LVOID,
3674 	"(morehelp COMMAND)\n"
3675 	"\"COMMAND\" may include \"*\" wildcards\n"
3676 	"Prints more info than \"(help COMMAND)\".")
3677 {
3678   char *pat;
3679   pattern p;
3680   int seen = 0;
3681   Help *h;
3682   Lake *cedar;
3683   FILE *outf;
3684 
3685   LDECLARE(("morehelp", LBEGIN,
3686 	    LLAKE, &cedar,
3687 	    LSTRING, &pat,
3688 	    LEND));
3689   if((outf = cedar->streamout) == NULL) outf = stdout;
3690   compile(pat, &p);
3691   for(h=helps; h!=NULL; h=h->next) {
3692     if(match(h->key, &p)) {
3693 #if 0
3694       fprintf(outf, "%s\n", h->message);
3695 #else
3696       print_help_formatted(outf, h->message);
3697 #endif
3698       seen++;
3699     }
3700   }
3701 
3702   if(seen==0) fprintf(outf, nomatch, pat);
3703   fflush(outf);
3704   return Lt;
3705 }
3706 
LInterestList(const char * funcname)3707 LInterest *LInterestList(const char *funcname)
3708 {
3709   int index = funcindex(funcname);
3710   if (index == REJECT) return NULL;
3711   return functable[index].interested;
3712 }
3713 
LakeName(Lake * lake)3714 const char *LakeName(Lake *lake)
3715 {
3716   return lake ? PoolName(lake->river) : NULL;
3717 }
3718 
LSummarize(LObject * obj)3719 const char *LSummarize(LObject *obj)
3720 {
3721   int len;
3722   static FILE *f;
3723   static char *summary;
3724 
3725   if(f == NULL) {
3726     f = tmpfile();
3727     if(f == NULL) {
3728       return strdup("???");
3729     }
3730   }
3731   rewind(f);
3732   LWrite(f, obj);
3733   fflush(f);
3734   len = ftell(f);
3735   rewind(f);
3736   if(len >= 80) len = 79;
3737   if(summary) {
3738     free(summary);
3739   }
3740   summary = malloc(len+1);
3741   summary[len] = '\0';
3742   if (fread(summary, len, 1, f) != 1) {
3743     free(summary);
3744     return strdup("???");
3745   }
3746   if(len >= 79) {
3747     strcpy(summary+75, " ...");
3748   }
3749   return summary;
3750 }
3751 
3752 /************************************************************************/
3753 
3754 /*
3755  * Local Variables: ***
3756  * mode: c ***
3757  * c-basic-offset: 2 ***
3758  * End: ***
3759  */
3760