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, © );
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, ©);
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, "e); /* consume '(' */
1256 while (LakeMore(lake)) {
1257 LObject *larg, *lval;
1258 char *arg;
1259
1260 if ((par = LakeNewSexpr(lake))) {
1261 /* (ARG VALUE) */
1262 LakeNextToken(lake, "e); /* 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, "e); /* 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, "e); /* 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, "e); /* 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, "e)) == 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, "e);
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, ©);
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, © );
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