1 /* Support for Lisp-style data.
2 Copyright (C) 1991-2000 Stanley T. Shebs.
3
4 Xconq is free software; you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation; either version 2, or (at your option)
7 any later version. See the file COPYING. */
8
9 /* (should have some deallocation support, since some game init data
10 can be discarded) */
11
12 #include "config.h"
13 #include "misc.h"
14 #include "lisp.h"
15 #include "game.h"
16
17 #ifdef MAC
18 extern int convert_mac_charcodes(int ch);
19 #endif
20
21 /* Declarations of local functions. */
22
23 static Obj *newobj(void);
24 static Symentry *lookup_string(char *str);
25 static int hash_name(char *str);
26
27 static int strmgetc(Strm *strm);
28 static void strmungetc(int ch, Strm *strm);
29 static void sprintf_context(char *buf, int n, int *start, int *end,
30 Strm *strm);
31 static Obj *read_form_aux(Strm *strm);
32 static Obj *read_list(Strm *strm);
33 static int read_delimited_text(Strm *strm, char *delim, int spacedelimits,
34 int eofdelimits);
35 static void internal_type_error(char *funname, Obj *x, char *errtype);
36
37 /* Pointer to "nil", the empty list. */
38
39 Obj *lispnil;
40
41 /* Pointer to "eof", which is returned if no more forms in a file. */
42
43 Obj *lispeof;
44
45 /* Pointer to a "closing paren" object used only during list reading. */
46
47 Obj *lispclosingparen;
48
49 /* Pointer to an "unbound" object that indicates unbound variables. */
50
51 Obj *lispunbound;
52
53 /* Current number of symbols in the symbol table. */
54
55 int numsymbols = 0;
56
57 /* Pointer to the base of the symbol table itself. */
58
59 static Symentry **symboltablebase = NULL;
60
61 /* The number of Lisp objects allocated so far. */
62
63 int lispmalloc = 0;
64
65 /* This variable is used to track the depth of nested #| |# comments. */
66
67 int commentdepth = 0;
68
69 int actually_read_lisp = TRUE;
70
71 #define BIGBUF 1000
72
73 static char *lispstrbuf = NULL;
74
75 static int *startlineno;
76 static int *endlineno;
77 static char *linenobuf;
78
79 static char *escapedthingbuf;
80
81 /* Allocate a new Lisp object, count it as such. */
82
83 static Obj *
newobj(void)84 newobj(void)
85 {
86 lispmalloc += sizeof(Obj);
87 return ((Obj *) xmalloc(sizeof(Obj)));
88 }
89
90 /* Pre-create some objects that should always exist. */
91
92 void
init_lisp(void)93 init_lisp(void)
94 {
95 /* Allocate Lisp's NIL. */
96 lispnil = newobj();
97 lispnil->type = NIL;
98 /* Do this so car/cdr of nil is nil, might cause infinite loops though. */
99 lispnil->v.cons.car = lispnil;
100 lispnil->v.cons.cdr = lispnil;
101 /* We use the eof object to recognize eof when reading a file. */
102 lispeof = newobj();
103 lispeof->type = EOFOBJ;
104 /* The "closing paren" object just flags closing parens while reading. */
105 lispclosingparen = newobj();
106 /* The "unbound" object is for unbound variables. */
107 lispunbound = newobj();
108 /* Set up the symbol table. */
109 symboltablebase = (Symentry **) xmalloc(256 * sizeof(Symentry *));
110 numsymbols = 0;
111 init_predefined_symbols();
112 escapedthingbuf = (char *)xmalloc(BUFSIZE);
113 }
114
115 /* Ultra-simple "streams" that can be stdio FILEs or strings. */
116
117 static int
strmgetc(Strm * strm)118 strmgetc(Strm *strm)
119 {
120 int ch;
121
122 if (strm->type == stringstrm) {
123 if (*(strm->ptr.sp) == '\0')
124 ch = EOF;
125 else
126 ch = *((strm->ptr.sp)++);
127 } else {
128 ch = getc(strm->ptr.fp);
129 #ifdef MAC
130 ch = convert_mac_charcodes(ch);
131 #endif
132 }
133 if (ch != EOF) {
134 ++(strm->numread);
135 strm->lastread[(strm->numread % (CONTEXTSIZE - 1))] = ch;
136 strm->lastread[((strm->numread + 1) % (CONTEXTSIZE - 1))] = '\0';
137 /* This is redundant unless we're at the end of the buffer. */
138 strm->lastread[(strm->numread % (CONTEXTSIZE - 1)) + 1] = '\0';
139 }
140 return ch;
141 }
142
143 static void
strmungetc(int ch,Strm * strm)144 strmungetc(int ch, Strm *strm)
145 {
146 if (strm->type == stringstrm) {
147 --strm->ptr.sp;
148 } else {
149 ungetc(ch, strm->ptr.fp);
150 }
151 --(strm->numread);
152 }
153
154 /* El cheapo Lisp reader. Lisp objects are generally advertised by
155 their first characters, but lots of semantics actions happen while
156 reading, so this isn't really a regular expression reader. */
157
158 Obj *
read_form(FILE * fp,int * p1,int * p2)159 read_form(FILE *fp, int *p1, int *p2)
160 {
161 Obj *rslt;
162 Strm tmpstrm;
163
164 commentdepth = 0;
165 startlineno = p1;
166 endlineno = p2;
167 tmpstrm.type = filestrm;
168 tmpstrm.ptr.fp = fp;
169 tmpstrm.numread = 0;
170 rslt = read_form_aux(&tmpstrm);
171 if (rslt == lispclosingparen) {
172 if (linenobuf == NULL)
173 linenobuf = (char *)xmalloc(BUFSIZE);
174 sprintf_context(linenobuf, BUFSIZE, startlineno, endlineno, &tmpstrm);
175 init_warning("extra close paren, substituting nil%s", linenobuf);
176 rslt = lispnil;
177 }
178 return rslt;
179 }
180
181 Obj *
read_form_from_string(char * str,int * p1,int * p2,char ** endstr)182 read_form_from_string(char *str, int *p1, int *p2, char **endstr)
183 {
184 Obj *rslt;
185 Strm tmpstrm;
186
187 commentdepth = 0;
188 startlineno = p1;
189 endlineno = p2;
190 tmpstrm.type = stringstrm;
191 tmpstrm.ptr.sp = str;
192 tmpstrm.numread = 0;
193 rslt = read_form_aux(&tmpstrm);
194 if (rslt == lispclosingparen) {
195 if (linenobuf == NULL)
196 linenobuf = (char *)xmalloc(BUFSIZE);
197 sprintf_context(linenobuf, BUFSIZE, startlineno, endlineno, &tmpstrm);
198 init_warning("extra close paren, substituting nil%s", linenobuf);
199 rslt = lispnil;
200 }
201 /* Record the next character to read from the string if possible. */
202 if (endstr != NULL)
203 *endstr = tmpstrm.ptr.sp;
204 return rslt;
205 }
206
207 static void
sprintf_context(char * buf,int n,int * start,int * end,Strm * strm)208 sprintf_context(char *buf, int n, int *start, int *end, Strm *strm)
209 {
210 int printedlineno = FALSE;
211
212 strcpy(buf, "(");
213 if (start != NULL && end != NULL) {
214 if (*start == *end) {
215 sprintf(buf + strlen(buf), "at line %d", *start);
216 } else {
217 sprintf(buf + strlen(buf), "lines %d to %d", *start, *end);
218 }
219 printedlineno = TRUE;
220 }
221 if (!empty_string(strm->lastread)) {
222 if (printedlineno)
223 strcat(buf, ", ");
224 strcat(buf, "context \"");
225 if (strm->numread > (CONTEXTSIZE - 1) && (strm->numread % (CONTEXTSIZE - 1)) > 0) {
226 strncpy(buf + strlen(buf), strm->lastread + (strm->numread % (CONTEXTSIZE - 1)), n - strlen(buf) - 1);
227 }
228 strncpy(buf + strlen(buf), strm->lastread, n - strlen(buf) - 1);
229 buf[n - 1] = '\0';
230 strcat(buf, "\"");
231 }
232 strcat(buf, ")");
233 }
234
235 /* The main body of the the Lisp reader, works from a stream and returns
236 an object. */
237
238 static Obj *
read_form_aux(Strm * strm)239 read_form_aux(Strm *strm)
240 {
241 int minus, factor, commentclosed, ch, ch2, ch3, ch4, num;
242 int numdice, dice, indice;
243
244 while ((ch = strmgetc(strm)) != EOF) {
245 /* Recognize nested comments specially. */
246 if (ch == '#') {
247 if ((ch2 = strmgetc(strm)) == '|') {
248 commentclosed = FALSE;
249 ++commentdepth;
250 while ((ch3 = strmgetc(strm)) != EOF) {
251 if (ch3 == '|') {
252 /* try to recognize # */
253 if ((ch4 = strmgetc(strm)) == '#') {
254 --commentdepth;
255 if (commentdepth == 0) {
256 commentclosed = TRUE;
257 break;
258 }
259 } else {
260 strmungetc(ch4, strm);
261 }
262 } else if (ch3 == '#') {
263 if ((ch4 = strmgetc(strm)) == '|') {
264 ++commentdepth;
265 } else {
266 strmungetc(ch4, strm);
267 }
268 } else if (ch3 == '\n') {
269 if (endlineno != NULL)
270 ++(*endlineno);
271 announce_read_progress();
272 }
273 }
274 if (!commentclosed) {
275 init_warning("comment not closed at eof");
276 }
277 /* Always pick up the next char. */
278 ch = strmgetc(strm);
279 } else {
280 strmungetc(ch2, strm);
281 return intern_symbol("#");
282 }
283 }
284 /* Regular lexical recognition. */
285 if (isspace(ch)) {
286 /* Nothing to do here except count lines. */
287 if (ch == '\n') {
288 if (endlineno != NULL)
289 ++(*endlineno);
290 if (startlineno != NULL)
291 ++(*startlineno);
292 announce_read_progress();
293 }
294 } else if (ch == ';') {
295 /* Discard all from here to the end of this line. */
296 while ((ch = strmgetc(strm)) != EOF && ch != '\n')
297 ;
298 if (endlineno != NULL)
299 ++(*endlineno);
300 announce_read_progress();
301 } else if (ch == '(') {
302 /* Jump into a list-reading mode. */
303 return read_list(strm);
304 } else if (ch == ')') {
305 /* This is just to flag the end of the list for read_list. */
306 return lispclosingparen;
307 } else if (ch == '"') {
308 read_delimited_text(strm, "\"", FALSE, FALSE);
309 if (!actually_read_lisp)
310 return lispnil;
311 return new_string(copy_string(lispstrbuf));
312 } else if (ch == '|') {
313 read_delimited_text(strm, "|", FALSE, FALSE);
314 if (!actually_read_lisp)
315 return lispnil;
316 return intern_symbol(lispstrbuf);
317 } else if (strchr("`'", ch)) {
318 if (!actually_read_lisp)
319 return lispnil;
320 return cons(intern_symbol("quote"),
321 cons(read_form_aux(strm), lispnil));
322 } else if (isdigit(ch) || ch == '-' || ch == '+' || ch == '.') {
323 numdice = dice = 0;
324 indice = FALSE;
325 minus = (ch == '-');
326 factor = (ch == '.' ? 100 : 1);
327 num = 0;
328 if (isdigit(ch))
329 num = ch - '0';
330 if (('-' == ch) || ('+' == ch)) {
331 ch2 = strmgetc(strm);
332 if (isspace(ch2) || (ch2 == ')')) {
333 strmungetc(ch2, strm);
334 if ('-' == ch)
335 return intern_symbol("-");
336 else
337 return intern_symbol("+");
338 }
339 strmungetc(ch2, strm);
340 }
341 while ((ch = strmgetc(strm)) != EOF) {
342 if (isdigit(ch)) {
343 /* should ignore decimal digits past second one */
344 num = num * 10 + ch - '0';
345 if (factor > 1)
346 factor /= 10;
347 } else if (ch == 'd') {
348 numdice = num;
349 num = 0;
350 indice = TRUE;
351 } else if (ch == '+' || ch == '-') {
352 dice = num;
353 num = 0;
354 indice = FALSE;
355 } else if (ch == '.') {
356 factor = 100;
357 } else {
358 break;
359 }
360 }
361 /* If number was followed by a % char, discard the char, otherwise
362 put it back on the stream. */
363 if (ch != '%' && ch != EOF)
364 strmungetc(ch, strm);
365 if (indice) {
366 dice = num;
367 num = 0;
368 }
369 if (minus)
370 num = 0 - num;
371 if (numdice > 0) {
372 /* Warn about out-of-bounds values. */
373 if (!between(0, numdice, 7))
374 init_warning(
375 "Number of dice in %dd%d+%d is %d, not between 0 and 7",
376 numdice, dice, num, numdice);
377 if (!between(0, dice, 15))
378 init_warning(
379 "Dice size in %dd%d+%d is %d, not between 0 and 15",
380 numdice, dice, num, dice);
381 if (!between(0, num, 127))
382 init_warning(
383 "Dice addon in %dd%d+%d is %d, not between 0 and 127",
384 numdice, dice, num, num);
385 num = (1 << 14) | (numdice << 11) | (dice << 7) | (num & 0x7f);
386 } else {
387 num = factor * num;
388 }
389 if (!actually_read_lisp)
390 return lispnil;
391 return new_number(num);
392 } else {
393 /* Read a regular symbol. */
394 /* The char we just looked will be the first char. */
395 strmungetc(ch, strm);
396 /* Now read until any special char seen. */
397 ch = read_delimited_text(strm, "();\"'`#", TRUE, TRUE);
398 /* Undo the extra char we read in order to detect the end
399 of the symbol. */
400 strmungetc(ch, strm);
401 /* Need to recognize nil specially here. */
402 if (strcmp("nil", lispstrbuf) == 0) {
403 return lispnil;
404 } else if (!actually_read_lisp) {
405 /* Recognize boundaries of non-reading specially. */
406 if (strcmp("else", lispstrbuf) == 0)
407 return intern_symbol(lispstrbuf);
408 if (strcmp("end-if", lispstrbuf) == 0)
409 return intern_symbol(lispstrbuf);
410 return lispnil;
411 } else {
412 return intern_symbol(lispstrbuf);
413 }
414 }
415 }
416 return lispeof;
417 }
418
419 /* Read a sequence of expressions terminated by a closing paren. This
420 works by looping; although recursion is more elegant, if the
421 compiler does not turn tail-recursion into loops, long lists can
422 blow the stack. (This has happened with real saved games.) */
423
424 static Obj *
read_list(Strm * strm)425 read_list(Strm *strm)
426 {
427 Obj *thecar, *thenext, *lis, *endlis;
428
429 thecar = read_form_aux(strm);
430 if (thecar == lispclosingparen) {
431 return lispnil;
432 } else if (thecar == lispeof) {
433 goto at_eof;
434 } else {
435 lis = cons(thecar, lispnil);
436 endlis = lis;
437 while (TRUE) {
438 thenext = read_form_aux(strm);
439 if (thenext == lispclosingparen) {
440 break;
441 } else if (thenext == lispeof) {
442 goto at_eof;
443 } else {
444 set_cdr(endlis, cons(thenext, lispnil));
445 endlis = cdr(endlis);
446 }
447 }
448 return lis;
449 }
450 at_eof:
451 if (linenobuf == NULL)
452 linenobuf = (char *)xmalloc(BUFSIZE);
453 sprintf_context(linenobuf, BUFSIZE, startlineno, endlineno, strm);
454 init_warning("missing a close paren, returning EOF%s", linenobuf);
455 return lispeof;
456 }
457
458 /* Read a quantity of text delimited by a char from the given string,
459 possibly also by whitespace or EOF. */
460
461 static int
read_delimited_text(Strm * strm,char * delim,int spacedelimits,int eofdelimits)462 read_delimited_text(Strm *strm, char *delim, int spacedelimits,
463 int eofdelimits)
464 {
465 int ch, octch, j = 0, warned = FALSE;
466
467 if (lispstrbuf == NULL)
468 lispstrbuf = (char *) xmalloc(BIGBUF);
469 while ((ch = strmgetc(strm)) != EOF
470 && (!spacedelimits || !isspace(ch))
471 && !strchr(delim, ch)) {
472 /* Handle escape char by replacing with next char,
473 or maybe interpret an octal sequence. */
474 if (ch == '\\') {
475 ch = strmgetc(strm);
476 /* Octal chars introduced by a leading zero. */
477 if (ch == '0') {
478 octch = 0;
479 /* Soak up numeric digits (don't complain about 8 or 9,
480 sloppy but traditional). */
481 while ((ch = strmgetc(strm)) != EOF && isdigit(ch)) {
482 octch = 8 * octch + ch - '0';
483 }
484 /* The non-digit char is actually next one in the string. */
485 strmungetc(ch, strm);
486 ch = octch;
487 }
488 }
489 if (j >= BIGBUF) {
490 /* Warn about buffer overflow, but only once per string,
491 then still read chars but discard them. */
492 if (!warned) {
493 init_warning(
494 "exceeded max sym/str length (%d chars), ignoring rest",
495 BIGBUF);
496 warned = TRUE;
497 }
498 } else {
499 lispstrbuf[j++] = ch;
500 }
501 }
502 lispstrbuf[j] = '\0';
503 return ch;
504 }
505
506 /* The usual list length function. */
507
508 int
length(Obj * list)509 length(Obj *list)
510 {
511 int rslt = 0;
512
513 while (list != lispnil) {
514 list = cdr(list);
515 ++rslt;
516 }
517 return rslt;
518 }
519
520
521 /* Basic allocation routines. */
522
523 Obj *
new_string(char * str)524 new_string(char *str)
525 {
526 Obj *N = newobj();
527
528 N->type = STRING;
529 N->v.str = str;
530 return N;
531 }
532
533 Obj *
new_number(int num)534 new_number(int num)
535 {
536 Obj *N = newobj();
537
538 N->type = NUMBER;
539 N->v.num = num;
540 return N;
541 }
542
543 Obj *
new_utype(int u)544 new_utype(int u)
545 {
546 Obj *N = newobj();
547
548 N->type = UTYPE;
549 N->v.num = u;
550 return N;
551 }
552
553 Obj *
new_mtype(int m)554 new_mtype(int m)
555 {
556 Obj *N = newobj();
557
558 N->type = MTYPE;
559 N->v.num = m;
560 return N;
561 }
562
563 Obj *
new_ttype(int t)564 new_ttype(int t)
565 {
566 Obj *N = newobj();
567
568 N->type = TTYPE;
569 N->v.num = t;
570 return N;
571 }
572
573 Obj *
new_atype(int a)574 new_atype(int a)
575 {
576 Obj *N = newobj();
577
578 N->type = ATYPE;
579 N->v.num = a;
580 return N;
581 }
582
583 Obj *
new_pointer(Obj * sym,char * ptr)584 new_pointer(Obj *sym, char *ptr)
585 {
586 Obj *N = newobj();
587
588 N->type = POINTER;
589 N->v.ptr.sym = sym;
590 N->v.ptr.data = ptr;
591 return N;
592 }
593
594 Obj *
cons(Obj * x,Obj * y)595 cons(Obj *x, Obj *y)
596 {
597 Obj *N = newobj();
598
599 N->type = CONS;
600 N->v.cons.car = x; N->v.cons.cdr = y;
601 /* Xconq's Lisp does not include dot notation for consing, so this
602 can only happen if there is an internal error somewhere. */
603 if (!listp(y))
604 run_error("cdr of cons is not a list");
605 return N;
606 }
607
608 void
type_warning(char * funname,Obj * x,char * errtype,Obj * subst)609 type_warning(char *funname, Obj *x, char *errtype, Obj *subst)
610 {
611 char buf1[BUFSIZE], buf2[BUFSIZE];
612
613 sprintlisp(buf1, x, BUFSIZE);
614 sprintlisp(buf2, subst, BUFSIZE);
615 run_warning("%s of non-%s `%s' being taken, returning `%s' instead",
616 funname, errtype, buf1, buf2);
617 }
618
619 /* This routine reports fatal errors with handling objects. */
620
621 static void
internal_type_error(char * funname,Obj * x,char * errtype)622 internal_type_error(char *funname, Obj *x, char *errtype)
623 {
624 char buf1[BUFSIZE];
625
626 sprintlisp(buf1, x, BUFSIZE);
627 run_error("%s of non-%s `%s'", funname, errtype, buf1);
628 }
629
630 /* The usual suspects. */
631
632 Obj *
car(Obj * x)633 car(Obj *x)
634 {
635 if (x->type == CONS || x->type == NIL) {
636 return x->v.cons.car;
637 } else {
638 internal_type_error("car", x, "list");
639 return lispnil;
640 }
641 }
642
643 Obj *
cdr(Obj * x)644 cdr(Obj *x)
645 {
646 if (x->type == CONS || x->type == NIL) {
647 return x->v.cons.cdr;
648 } else {
649 internal_type_error("cdr", x, "list");
650 return lispnil;
651 }
652 }
653
654 Obj *
cadr(Obj * x)655 cadr(Obj *x)
656 {
657 return car(cdr(x));
658 }
659
660 Obj *
cddr(Obj * x)661 cddr(Obj *x)
662 {
663 return cdr(cdr(x));
664 }
665
666 Obj *
caddr(Obj * x)667 caddr(Obj *x)
668 {
669 return car(cdr(cdr(x)));
670 }
671
672 Obj *
cdddr(Obj * x)673 cdddr(Obj *x)
674 {
675 return cdr(cdr(cdr(x)));
676 }
677
678 void
set_cdr(Obj * x,Obj * v)679 set_cdr(Obj *x, Obj *v)
680 {
681 if (x->type == CONS) {
682 x->v.cons.cdr = v;
683 } else {
684 internal_type_error("set_cdr", x, "cons");
685 }
686 }
687
688 /* Return the string out of both strings and symbols. */
689
690 char *
c_string(Obj * x)691 c_string(Obj *x)
692 {
693 if (x->type == STRING) {
694 return x->v.str;
695 } else if (x->type == SYMBOL) {
696 return x->v.sym.symentry->name;
697 } else {
698 /* (should be internal_type_error?) */
699 type_warning("c_string", x, "string/symbol", lispnil);
700 return "";
701 }
702 }
703
704 /* Return the actual number in a number object. */
705
706 int
c_number(Obj * x)707 c_number(Obj *x)
708 {
709 if (x->type == NUMBER
710 || x->type == UTYPE
711 || x->type == MTYPE
712 || x->type == TTYPE
713 || x->type == ATYPE) {
714 return x->v.num;
715 } else {
716 /* (should be internal_type_error?) */
717 type_warning("c_number", x, "number", lispnil);
718 return 0;
719 }
720 }
721
722 Obj *
intern_symbol(char * str)723 intern_symbol(char *str)
724 {
725 int n;
726 Symentry *se;
727 Obj *new1;
728
729 se = lookup_string(str);
730 if (se) {
731 return se->symbol;
732 } else {
733 new1 = newobj();
734 new1->type = SYMBOL;
735 se = (Symentry *) xmalloc(sizeof(Symentry));
736 new1->v.sym.symentry = se;
737 /* Declare a newly created symbol to be unbound. */
738 new1->v.sym.value = lispunbound;
739 se->name = copy_string(str);
740 se->symbol = new1;
741 se->constantp = FALSE;
742 n = hash_name(str);
743 /* Push the symbol entry onto the front of its hash bucket. */
744 se->next = symboltablebase[n];
745 symboltablebase[n] = se;
746 ++numsymbols;
747 return new1;
748 }
749 }
750
751 /* Given a string, try to find a symbol entry with that as its name. */
752
753 static Symentry *
lookup_string(char * str)754 lookup_string(char *str)
755 {
756 Symentry *se;
757
758 for (se = symboltablebase[hash_name(str)]; se != NULL; se = se->next) {
759 if (strcmp(se->name, str) == 0)
760 return se;
761 }
762 return NULL;
763 }
764
765 static int
hash_name(char * str)766 hash_name(char *str)
767 {
768 int rslt = 0;
769
770 while (*str != '\0')
771 rslt ^= *str++;
772 return (ABS(rslt) & 0xff);
773 }
774
775 Obj *
symbol_value(Obj * sym)776 symbol_value(Obj *sym)
777 {
778 Obj *val = sym->v.sym.value;
779
780 if (val == lispunbound) {
781 run_warning("unbound symbol `%s', substituting nil", c_string(sym));
782 val = lispnil;
783 }
784 return val;
785 }
786
787 Obj *
setq(Obj * sym,Obj * x)788 setq(Obj *sym, Obj *x)
789 {
790 /* All the callers check for symbolness, but be careful. */
791 if (!symbolp(sym)) {
792 internal_type_error("setq", sym, "symbol");
793 }
794 if (constantp(sym)) {
795 run_warning("Can't alter the constant `%s', ignoring attempt",
796 c_string(sym));
797 return x;
798 }
799 sym->v.sym.value = x;
800 return x;
801 }
802
803 void
makunbound(Obj * sym)804 makunbound(Obj *sym)
805 {
806 sym->v.sym.value = lispunbound;
807 }
808
809 void
flag_as_constant(Obj * sym)810 flag_as_constant(Obj *sym)
811 {
812 sym->v.sym.symentry->constantp = TRUE;
813 }
814
815 int
constantp(Obj * sym)816 constantp(Obj *sym)
817 {
818 return (sym->v.sym.symentry->constantp);
819 }
820
821 int
numberp(Obj * x)822 numberp(Obj *x)
823 {
824 return (x->type == NUMBER);
825 }
826
827 int
stringp(Obj * x)828 stringp(Obj *x)
829 {
830 return (x->type == STRING);
831 }
832
833 int
symbolp(Obj * x)834 symbolp(Obj *x)
835 {
836 return (x->type == SYMBOL);
837 }
838
839 int
consp(Obj * x)840 consp(Obj *x)
841 {
842 return (x->type == CONS);
843 }
844
845 int
utypep(Obj * x)846 utypep(Obj *x)
847 {
848 return (x->type == UTYPE);
849 }
850
851 int
mtypep(Obj * x)852 mtypep(Obj *x)
853 {
854 return (x->type == MTYPE);
855 }
856
857 int
ttypep(Obj * x)858 ttypep(Obj *x)
859 {
860 return (x->type == TTYPE);
861 }
862
863 int
atypep(Obj * x)864 atypep(Obj *x)
865 {
866 return (x->type == ATYPE);
867 }
868
869 int
pointerp(Obj * x)870 pointerp(Obj *x)
871 {
872 return (x->type == POINTER);
873 }
874
875 int
boundp(Obj * sym)876 boundp(Obj *sym)
877 {
878 return (sym->v.sym.value != lispunbound);
879 }
880
881 int
numberishp(Obj * x)882 numberishp(Obj *x)
883 {
884 return (x->type == NUMBER
885 || x->type == UTYPE
886 || x->type == MTYPE
887 || x->type == TTYPE
888 || x->type == ATYPE);
889 }
890
891 int
listp(Obj * x)892 listp(Obj *x)
893 {
894 return (x->type == NIL || x->type == CONS);
895 }
896
897 /* General structural equality test. Assumes that it is not getting
898 passed any circular structures, which should never happen in Xconq. */
899
900 int
equal(Obj * x,Obj * y)901 equal(Obj *x, Obj *y)
902 {
903 /* Objects of different types can never be equal. */
904 if (x->type != y->type)
905 return FALSE;
906 /* Identical objects are always equal. */
907 if (x == y)
908 return TRUE;
909 switch (x->type) {
910 case NUMBER:
911 case UTYPE:
912 case MTYPE:
913 case TTYPE:
914 case ATYPE:
915 return (c_number(x) == c_number(y));
916 case STRING:
917 return (strcmp(c_string(x), c_string(y)) == 0);
918 case SYMBOL:
919 return (strcmp(c_string(x), c_string(y)) == 0);
920 case CONS:
921 return (equal(car(x), car(y)) && equal(cdr(x), cdr(y)));
922 case POINTER:
923 return FALSE;
924 default:
925 case_panic("lisp type", x->type);
926 return FALSE;
927 }
928 }
929
930 int
member(Obj * x,Obj * lis)931 member(Obj *x, Obj *lis)
932 {
933 if (lis == lispnil) {
934 return FALSE;
935 } else if (!consp(lis)) {
936 /* should probably be an error of some sort */
937 return FALSE;
938 } else if (equal(x, car(lis))) {
939 return TRUE;
940 } else {
941 return member(x, cdr(lis));
942 }
943 }
944
945 /* Return the nth element of a list. */
946
947 Obj *
elt(Obj * lis,int n)948 elt(Obj *lis, int n)
949 {
950 while (n-- > 0) {
951 lis = cdr(lis);
952 }
953 return car(lis);
954 }
955
956 Obj *
reverse(Obj * lis)957 reverse(Obj *lis)
958 {
959 Obj *rslt = lispnil;
960
961 for (; lis != lispnil; lis = cdr(lis)) {
962 rslt = cons(car(lis), rslt);
963 }
964 return rslt;
965 }
966
967 Obj *
find_at_key(Obj * lis,char * key)968 find_at_key(Obj *lis, char *key)
969 {
970 Obj *rest, *bdgs, *bdg;
971
972 for_all_list(lis, rest) {
973 bdgs = car(rest);
974 bdg = car(bdgs);
975 if (stringp(bdg) && strcmp(key, c_string(bdg)) == 0) {
976 return cdr(bdgs);
977 }
978 }
979 return lispnil;
980 }
981
982 Obj *
replace_at_key(Obj * lis,char * key,Obj * newval)983 replace_at_key(Obj *lis, char *key, Obj *newval)
984 {
985 Obj *rest, *bdgs, *bdg;
986
987 for_all_list(lis, rest) {
988 bdgs = car(rest);
989 bdg = car(bdgs);
990 if (stringp(bdg) && strcmp(key, c_string(bdg)) == 0) {
991 set_cdr(bdgs, newval);
992 return lis;
993 }
994 }
995 return cons(cons(new_string(key), newval), lis);
996 }
997
998 /* Is the object quoted? */
999
1000 int
is_quoted_lisp(Obj * x)1001 is_quoted_lisp(Obj *x)
1002 {
1003 enum keywords code;
1004 Obj *specialform = lispnil;
1005
1006 assert_error(x, "Attempted to access a NULL GDL object");
1007 if (lispnil == x)
1008 return FALSE;
1009 switch (x->type) {
1010 case CONS:
1011 specialform = car(x);
1012 if (symbolp(specialform)
1013 && !boundp(specialform)
1014 && (code =
1015 (enum keywords)keyword_code(c_string(specialform))) >= 0) {
1016 switch (code) {
1017 case K_QUOTE:
1018 return TRUE;
1019 default:
1020 return FALSE;
1021 }
1022 }
1023 break;
1024 default:
1025 return FALSE;
1026 }
1027 return FALSE;
1028 }
1029
1030 /* Print an integer or dice spec according to type. */
1031 void
fprint_num_or_dice(FILE * fp,int x,int valtype)1032 fprint_num_or_dice(FILE *fp, int x, int valtype)
1033 {
1034 int addend = -1;
1035
1036 if ((TABDICE == valtype) && (1 == (x >> 14))) {
1037 addend = x & 0x7f;
1038 if (addend > 0)
1039 fprintf(fp, " %dd%d+%d", (x >> 11) & 0x07, (x >> 7) & 0x0f, addend);
1040 else
1041 fprintf(fp, " %dd%d", (x >> 11) & 0x07, (x >> 7) & 0x0f);
1042 } else {
1043 fprintf(fp, " %d", x);
1044 }
1045 }
1046
1047 /* Print the contents of a table at the given index in the table definitions
1048 array. */
1049 /* (TODO: Should perhaps use something similar to 'write_table' to get
1050 more compact output.) */
1051 void
fprinttable(FILE * fp,int n)1052 fprinttable(FILE *fp, int n)
1053 {
1054 int i = -1, j = -1;
1055 int (*getter)(int i, int j) = NULL;
1056 int dim1 = -1, dim2 = -1, valtype = -1;
1057
1058 getter = tabledefns[n].getter;
1059 dim1 = numtypes_from_index_type(tabledefns[n].index1);
1060 dim2 = numtypes_from_index_type(tabledefns[n].index2);
1061 valtype = tabledefns[n].valtype;
1062 fprintf(fp, "\n(");
1063 for (i = 0; i < dim1; ++i) {
1064 fprintf(fp, "\n\t(");
1065 for (j = 0; j < dim2; ++j) {
1066 fprint_num_or_dice(fp, getter(i, j), valtype);
1067 }
1068 fprintf(fp, ")");
1069 }
1070 fprintf(fp, ")\n");
1071 }
1072
1073 void
fprintlisp(FILE * fp,Obj * oobj)1074 fprintlisp(FILE *fp, Obj *oobj)
1075 {
1076 int needescape;
1077 char *str, *tmp;
1078 Obj *obj = NULL;
1079 int i = -1;
1080
1081 /* Doublecheck, just in case caller is not so careful. */
1082 if (oobj == NULL) {
1083 run_warning("Trying to print NULL as object, skipping");
1084 return;
1085 }
1086 obj = oobj;
1087 #if (0)
1088 /* Evaluate symbol down to the object it represents. */
1089 if (symbolp(obj) && boundp(obj) && !pointerp(obj)) {
1090 while (symbolp(obj) && boundp(obj))
1091 obj = eval_symbol(obj);
1092 }
1093 #endif
1094 /* Decide what to print depending on type of object. */
1095 switch (obj->type) {
1096 case NIL:
1097 fprintf(fp, "nil");
1098 break;
1099 case NUMBER:
1100 fprintf(fp, "%d", obj->v.num);
1101 break;
1102 case STRING:
1103 if (strchr(obj->v.str, '"')) {
1104 fprintf(fp, "\"");
1105 for (tmp = obj->v.str; *tmp != '\0'; ++tmp) {
1106 if (*tmp == '"')
1107 fprintf(fp, "\\");
1108 fprintf(fp, "%c", *tmp);
1109 }
1110 fprintf(fp, "\"");
1111 } else {
1112 /* Just printf the whole string. */
1113 fprintf(fp, "\"%s\"", obj->v.str);
1114 }
1115 break;
1116 case SYMBOL:
1117 needescape = FALSE;
1118 str = c_string(obj);
1119 if (isdigit(str[0])) {
1120 needescape = TRUE;
1121 } else {
1122 /* Scan the symbol's name looking for special chars. */
1123 for (tmp = str; *tmp != '\0'; ++tmp) {
1124 if (strchr(" ()#\";|", *tmp)) {
1125 needescape = TRUE;
1126 break;
1127 }
1128 }
1129 }
1130 if (needescape) {
1131 fprintf(fp, "|%s|", str);
1132 } else {
1133 fprintf(fp, "%s", str);
1134 }
1135 /* Check to see if we are dealing with a table. */
1136 for (i = 0; tabledefns[i].name != NULL; ++i) {
1137 if (!strcmp(str, tabledefns[i].name)) {
1138 fprinttable(fp, i);
1139 break;
1140 }
1141 }
1142 break;
1143 case CONS:
1144 fprintf(fp, "(");
1145 fprintlisp(fp, car(obj));
1146 /* Note that there are no dotted pairs in our version of Lisp. */
1147 fprint_list(fp, cdr(obj));
1148 break;
1149 case UTYPE:
1150 fprintf(fp, "u#%d", obj->v.num);
1151 break;
1152 case MTYPE:
1153 fprintf(fp, "m#%d", obj->v.num);
1154 break;
1155 case TTYPE:
1156 fprintf(fp, "t#%d", obj->v.num);
1157 break;
1158 case ATYPE:
1159 fprintf(fp, "a#%d", obj->v.num);
1160 break;
1161 case POINTER:
1162 fprintlisp(fp, obj->v.ptr.sym);
1163 fprintf(fp, " #|0x%lx|#", (long) obj->v.ptr.data);
1164 break;
1165 default:
1166 case_panic("lisp type", obj->type);
1167 break;
1168 }
1169 }
1170
1171 void
fprint_list(FILE * fp,Obj * obj)1172 fprint_list(FILE *fp, Obj *obj)
1173 {
1174 Obj *tmp;
1175
1176 for_all_list(obj, tmp) {
1177 fprintf(fp, " ");
1178 fprintlisp(fp, car(tmp));
1179 }
1180 fprintf(fp, ")");
1181 }
1182
1183 void
sprintlisp(char * buf,Obj * obj,int maxlen)1184 sprintlisp(char *buf, Obj *obj, int maxlen)
1185 {
1186 if (maxlen < 10) {
1187 strcpy(buf, " ... ");
1188 return;
1189 }
1190 switch (obj->type) {
1191 case NIL:
1192 strcpy(buf, "nil");
1193 break;
1194 case NUMBER:
1195 sprintf(buf, "%d", obj->v.num);
1196 break;
1197 case STRING:
1198 if (maxlen < (strlen(obj->v.str) + 2)) {
1199 strcpy(buf, " ... ");
1200 return;
1201 }
1202 /* (should print escape chars if needed) */
1203 sprintf(buf, "\"%s\"", obj->v.str);
1204 break;
1205 case SYMBOL:
1206 if (maxlen < strlen(c_string(obj))) {
1207 strcpy(buf, " ... ");
1208 return;
1209 }
1210 /* (should print escape chars if needed) */
1211 sprintf(buf, "%s", c_string(obj));
1212 break;
1213 case CONS:
1214 strcpy(buf, "(");
1215 sprintlisp(buf + 1, car(obj), maxlen - 1);
1216 /* No dotted pairs allowed in our version of Lisp. */
1217 sprint_list(buf+strlen(buf), cdr(obj), maxlen - strlen(buf));
1218 break;
1219 case UTYPE:
1220 sprintf(buf, "u#%d", obj->v.num);
1221 break;
1222 case MTYPE:
1223 sprintf(buf, "m#%d", obj->v.num);
1224 break;
1225 case TTYPE:
1226 sprintf(buf, "t#%d", obj->v.num);
1227 break;
1228 case ATYPE:
1229 sprintf(buf, "a#%d", obj->v.num);
1230 break;
1231 case POINTER:
1232 sprintlisp(buf, obj->v.ptr.sym, maxlen);
1233 sprintf(buf+strlen(buf), " #|0x%lx|#", (long) obj->v.ptr.data);
1234 break;
1235 default:
1236 case_panic("lisp type", obj->type);
1237 break;
1238 }
1239 }
1240
1241 void
sprint_list(char * buf,Obj * obj,int maxlen)1242 sprint_list(char *buf, Obj *obj, int maxlen)
1243 {
1244 Obj *tmp;
1245
1246 buf[0] = '\0';
1247 for (tmp = obj; tmp != lispnil; tmp = cdr(tmp)) {
1248 if ((maxlen - strlen(buf)) < 10) {
1249 strcpy(buf, " ... ");
1250 break;
1251 }
1252 strcat(buf, " ");
1253 sprintlisp(buf+strlen(buf), car(tmp), maxlen - strlen(buf));
1254 }
1255 strcat(buf, ")");
1256 }
1257
1258 /* These two routines make sure that any symbols and strings can
1259 be read in again. */
1260
1261 char *
escaped_symbol(char * str)1262 escaped_symbol(char *str)
1263 {
1264 char *tmp = str;
1265
1266 if (str[0] == '|' && str[strlen(str)-1] == '|')
1267 return str;
1268 if (isdigit(str[0])) {
1269 sprintf(escapedthingbuf, "|%s|", str);
1270 return escapedthingbuf;
1271 }
1272 while (*tmp != '\0') {
1273 if (((char *) strchr(" ()#\";|", *tmp)) != NULL) {
1274 sprintf(escapedthingbuf, "|%s|", str);
1275 return escapedthingbuf;
1276 }
1277 ++tmp;
1278 }
1279 return str;
1280 }
1281
1282 /* Note that this works correctly on NULL strings, turning them into
1283 strings of length 0. */
1284
1285 char *
escaped_string(char * str)1286 escaped_string(char *str)
1287 {
1288 char *tmp = str, *rslt = escapedthingbuf;
1289
1290 *rslt++ = '"';
1291 if (str != NULL) {
1292 while (*tmp != 0) {
1293 if ((*tmp == '"') || (*tmp == '\\'))
1294 *rslt++ = '\\';
1295 *rslt++ = *tmp++;
1296 }
1297 }
1298 *rslt++ = '"';
1299 *rslt = '\0';
1300 return escapedthingbuf;
1301 }
1302
1303 /* The escaped_string() function makes a dangerous assumption about
1304 the length of an escaped (or even unescaped) string being less than
1305 the BUFSIZE, which is the size of escapedthingbuf.
1306 safe_escaped_string() is slightly less efficient, but avoids this
1307 assumption. Do note, however, that safe_escaped_string() can result
1308 in a memory leak, if the caller does not free the result after
1309 using it.
1310 */
1311
1312 char *
safe_escaped_string(char * str,int len)1313 safe_escaped_string(char *str, int len)
1314 {
1315 char *tmp = str;
1316 char *rsltbase = NULL;
1317 char *rslt = NULL;
1318 int amt = len*2 + 3;
1319
1320 rsltbase = (char *)malloc(amt);
1321 if (NULL == rsltbase){
1322 Dprintf("Unable to allocate %d bytes.\n", amt);
1323 run_error("Memory exhausted!!");
1324 exit(1); /* Just to make sure. */
1325 }
1326 rslt = rsltbase;
1327 *rslt++ = '"';
1328 if (str != NULL) {
1329 while (*tmp != 0) {
1330 if ((*tmp == '"') || (*tmp == '\\'))
1331 *rslt++ = '\\';
1332 *rslt++ = *tmp++;
1333 }
1334 }
1335 *rslt++ = '"';
1336 *rslt = '\0';
1337 return rsltbase;
1338 }
1339
1340
1341 #ifdef DEBUGGING
1342 /* For calling from debuggers, at least that those that support output
1343 to stderr. */
1344
1345 void
dlisp(Obj * x)1346 dlisp(Obj *x)
1347 {
1348 fprintlisp(stderr, x);
1349 fprintf(stderr, "\n");
1350 }
1351 #endif /* DEBUGGING */
1352
1353 void
print_form_and_value(FILE * fp,Obj * form)1354 print_form_and_value(FILE *fp, Obj *form)
1355 {
1356 fprintlisp(fp, form);
1357 if (symbolp(form)) {
1358 if (boundp(form)) {
1359 fprintf(fp, " -> ");
1360 fprintlisp(fp, symbol_value(form));
1361 } else {
1362 fprintf(fp, " <unbound>");
1363 }
1364 }
1365 fprintf(fp, "\n");
1366 }
1367
1368 Obj *
append_two_lists(Obj * x1,Obj * x2)1369 append_two_lists(Obj *x1, Obj *x2)
1370 {
1371 if (!listp(x1))
1372 x1 = cons(x1, lispnil);
1373 if (!listp(x2))
1374 x2 = cons(x2, lispnil);
1375 if (x2 == lispnil) {
1376 return x1;
1377 } else if (x1 == lispnil) {
1378 return x2;
1379 } else {
1380 return cons(car(x1), append_two_lists(cdr(x1), x2));
1381 }
1382 }
1383
1384 Obj *
append_lists(Obj * lis)1385 append_lists(Obj *lis)
1386 {
1387 if (lis == lispnil) {
1388 return lispnil;
1389 } else if (!consp(lis)) {
1390 return cons(lis, lispnil);
1391 } else {
1392 return append_two_lists(car(lis), append_lists(cdr(lis)));
1393 }
1394 }
1395
1396 /* Remove all occurrences of a single object from a given list. */
1397
1398 Obj *
remove_from_list(Obj * element,Obj * lis)1399 remove_from_list(Obj *element, Obj *lis)
1400 {
1401 Obj *tmp;
1402
1403 if (lis == lispnil) {
1404 return lispnil;
1405 } else {
1406 tmp = remove_from_list(element, cdr(lis));
1407 if (equal(element, car(lis))) {
1408 return tmp;
1409 } else {
1410 return cons(car(lis), tmp);
1411 }
1412 }
1413 }
1414
1415 /* Remove all occurrences of each object in a list of objects from a
1416 given list. */
1417
1418 Obj *
remove_list_from_list(Obj * rlist,Obj * slist)1419 remove_list_from_list(Obj *rlist, Obj *slist)
1420 {
1421 Obj *tmp = lispnil;
1422
1423 if (lispnil == rlist)
1424 return slist;
1425 if (lispnil == slist)
1426 return lispnil;
1427 if (!consp(rlist)) {
1428 run_warning("Attempted to 'remove-list' using a non-list.");
1429 return lispnil;
1430 }
1431 tmp = remove_list_from_list(cdr(rlist), slist);
1432 return remove_from_list(car(rlist), tmp);
1433 }
1434
1435 void
push_binding(Obj ** lis,Obj * key,Obj * val)1436 push_binding(Obj **lis, Obj *key, Obj *val)
1437 {
1438 *lis = cons(cons(key, cons(val, lispnil)), *lis);
1439 }
1440
1441 void
push_cdr_binding(Obj ** lis,Obj * key,Obj * val)1442 push_cdr_binding(Obj **lis, Obj *key, Obj *val)
1443 {
1444 *lis = cons(cons(key, val), *lis);
1445 }
1446
1447 void
push_int_binding(Obj ** lis,Obj * key,int val)1448 push_int_binding(Obj **lis, Obj *key, int val)
1449 {
1450 *lis = cons(cons(key, cons(new_number(val), lispnil)), *lis);
1451 }
1452
1453 void
push_key_binding(Obj ** lis,int key,Obj * val)1454 push_key_binding(Obj **lis, int key, Obj *val)
1455 {
1456 *lis = cons(cons(intern_symbol(keyword_name((enum keywords)key)), cons(val, lispnil)), *lis);
1457 }
1458
1459 void
push_key_cdr_binding(Obj ** lis,int key,Obj * val)1460 push_key_cdr_binding(Obj **lis, int key, Obj *val)
1461 {
1462 *lis = cons(cons(intern_symbol(keyword_name((enum keywords)key)), val), *lis);
1463 }
1464
1465 void
push_key_int_binding(Obj ** lis,int key,int val)1466 push_key_int_binding(Obj **lis, int key, int val)
1467 {
1468 *lis = cons(cons(intern_symbol(keyword_name((enum keywords)key)),
1469 cons(new_number(val), lispnil)), *lis);
1470 }
1471
1472 /* Our version of evaluation derefs symbols and evals through lists,
1473 unless the list car is a "special form". */
1474
1475 Obj *
eval(Obj * x)1476 eval(Obj *x)
1477 {
1478 int code;
1479 Obj *specialform = lispnil;
1480
1481 switch (x->type) {
1482 case SYMBOL:
1483 return eval_symbol(x);
1484 case CONS:
1485 specialform = car(x);
1486 if (symbolp(specialform)
1487 && !boundp(specialform)
1488 && (code = keyword_code(c_string(specialform))) >= 0) {
1489 switch (code) {
1490 case K_QUOTE:
1491 return cadr(x);
1492 case K_LIST:
1493 return eval_list(cdr(x));
1494 case K_APPEND:
1495 return append_lists(eval_list(cdr(x)));
1496 case K_REMOVE:
1497 return remove_from_list(eval(cadr(x)), eval(caddr(x)));
1498 case K_REMOVE_LIST:
1499 return remove_list_from_list(eval(cadr(x)), eval(caddr(x)));
1500 case K_NOT: case K_AND: case K_OR:
1501 return eval_boolean_expression(x);
1502 case K_PLUS: case K_MINUS: case K_MULTIPLY: case K_DIVIDE:
1503 return eval_arithmetic_expression(x);
1504 case K_EQ: case K_NE: case K_LT: case K_LE: case K_GT: case K_GE:
1505 return eval_arithmetic_comparison_expression(x);
1506 default:
1507 break;
1508 }
1509 }
1510 /* A dubious default, but convenient. */
1511 return eval_list(x);
1512 default:
1513 /* Everything else evaluates to itself. */
1514 return x;
1515 }
1516 }
1517
1518 /* Some symbols are lazily bound, meaning that they don't get a value
1519 until it is first asked for. */
1520
1521 Obj *
eval_symbol(Obj * sym)1522 eval_symbol(Obj *sym)
1523 {
1524 if (boundp(sym)) {
1525 return symbol_value(sym);
1526 } else if (lazy_bind(sym)) {
1527 return symbol_value(sym);
1528 } else {
1529 run_warning("`%s' is unbound, returning self", c_string(sym));
1530 /* kind of a hack */
1531 return sym;
1532 }
1533 }
1534
1535 /* List evaluation just blasts straight through the list. */
1536
1537 Obj *
eval_list(Obj * lis)1538 eval_list(Obj *lis)
1539 {
1540 if (lis == lispnil) {
1541 return lispnil;
1542 } else {
1543 return cons(eval(car(lis)), eval_list(cdr(lis)));
1544 }
1545 }
1546
1547 /* Evaluate a boolean expression as Common Lisp would. */
1548
1549 Obj *
eval_boolean_expression(Obj * expr)1550 eval_boolean_expression(Obj *expr)
1551 {
1552 int code = -1;
1553 Obj *op = lispnil, *terms = lispnil, *tmpeval = lispnil;
1554
1555 /* If empty list return empty list. */
1556 if (lispnil == expr)
1557 return lispnil;
1558 /*! \note Do we need to handle just the symbols by themselves to get
1559 identity? */
1560 /* If a list, then try to do a boolean eval of it. */
1561 if (consp(expr)) {
1562 op = car(expr);
1563 if (symbolp(op) && !boundp(op)
1564 && (code = keyword_code(c_string(op))) >= 0) {
1565 switch (code) {
1566 case K_NOT: /* Logical NOT. */
1567 if (lispnil == cdr(expr))
1568 return new_number(TRUE);
1569 else
1570 return lispnil;
1571 break;
1572 case K_AND: /* Logical AND with short-circuit. */
1573 for_all_list(cdr(expr), terms) {
1574 if (lispnil == eval(car(terms)))
1575 return lispnil;
1576 if (lispnil == cdr(terms))
1577 return car(terms);
1578 }
1579 return lispnil;
1580 case K_OR: /* Logical inclusive-OR with short-circuit. */
1581 for_all_list(cdr(expr), terms) {
1582 tmpeval = eval(car(terms));
1583 if (lispnil != tmpeval)
1584 return tmpeval;
1585 }
1586 return lispnil;
1587 default:
1588 run_warning("Illegal boolean keyword %s encountered",
1589 c_string(op));
1590 return lispnil;
1591 }
1592 }
1593 }
1594 /* We don't know how to deal with anything else. */
1595 else {
1596 run_warning(
1597 "Boolean operator expected but none found in an expression");
1598 return expr;
1599 }
1600 return lispnil;
1601 }
1602
1603 /* Evaluate a boolean expression with a single-parameter evaluator. */
1604
1605 int
eval_boolean_expression(Obj * expr,int (* fn)(Obj *),int dflt)1606 eval_boolean_expression(Obj *expr, int (*fn)(Obj *), int dflt)
1607 {
1608 char *opname;
1609
1610 if (expr == lispnil) {
1611 return dflt;
1612 } else if (consp(expr) && symbolp(car(expr))) {
1613 opname = c_string(car(expr));
1614 switch (keyword_code(opname)) {
1615 case K_AND:
1616 return (eval_boolean_expression(cadr(expr), fn, dflt)
1617 && eval_boolean_expression(car(cddr(expr)), fn, dflt));
1618 case K_OR:
1619 return (eval_boolean_expression(cadr(expr), fn, dflt)
1620 || eval_boolean_expression(car(cddr(expr)), fn, dflt));
1621 case K_NOT:
1622 return !eval_boolean_expression(cadr(expr), fn, dflt);
1623 default:
1624 return (*fn)(expr);
1625 }
1626 } else {
1627 return (*fn)(expr);
1628 }
1629 }
1630
1631 /* Evaluate a boolean expression with using a parambox evaluator. */
1632
1633 int
eval_boolean_expression(Obj * expr,int (* fn)(Obj *,ParamBox *),int dflt,ParamBox * pbox)1634 eval_boolean_expression(Obj *expr, int (*fn)(Obj *, ParamBox *), int dflt,
1635 ParamBox *pbox)
1636 {
1637 char *opname;
1638
1639 if (expr == lispnil) {
1640 return dflt;
1641 } else if (consp(expr) && symbolp(car(expr))) {
1642 opname = c_string(car(expr));
1643 switch (keyword_code(opname)) {
1644 case K_AND:
1645 return (eval_boolean_expression(cadr(expr), fn, dflt, pbox)
1646 && eval_boolean_expression(car(cddr(expr)), fn, dflt,
1647 pbox));
1648 case K_OR:
1649 return (eval_boolean_expression(cadr(expr), fn, dflt, pbox)
1650 || eval_boolean_expression(car(cddr(expr)), fn, dflt,
1651 pbox));
1652 case K_NOT:
1653 return !eval_boolean_expression(cadr(expr), fn, dflt, pbox);
1654 default:
1655 return (*fn)(expr, pbox);
1656 }
1657 } else {
1658 return (*fn)(expr, pbox);
1659 }
1660 }
1661
1662 int
eval_number(Obj * val,int * isnumber)1663 eval_number(Obj *val, int *isnumber)
1664 {
1665 /* (should have a non-complaining eval for this) */
1666 if (numberp(val)) {
1667 *isnumber = TRUE;
1668 return c_number(val);
1669 } else if (symbolp(val)
1670 && boundp(val)
1671 && numberp(symbol_value(val))) {
1672 *isnumber = TRUE;
1673 return c_number(symbol_value(val));
1674 } else {
1675 *isnumber = FALSE;
1676 return 0;
1677 }
1678 }
1679
1680 /* Evaluate an arithmetic expression. (Operator precedence is not
1681 considered because it is naturally enforced by the structure of the
1682 lists.) */
1683
1684 #define CONSIFY_IF_NUMBER(lispeval, lisptmp) \
1685 (numberp((lisptmp) = (lispeval)) ? cons(lisptmp, lispnil) : lisptmp)
1686
1687 Obj *
eval_arithmetic_expression(Obj * expr)1688 eval_arithmetic_expression(Obj *expr)
1689 {
1690 Obj *op = lispnil, *opnds = lispnil, *opnd = lispnil, *opnd2 = lispnil;
1691 Obj *tmprslt = lispnil, *rslt = lispnil;
1692 enum keywords opcode;
1693 int opndlength = 0;
1694 int operated = FALSE;
1695
1696 if (lispnil == expr) {
1697 run_warning("Attempted to evaluate a bad arithmetic expression.");
1698 return lispnil;
1699 }
1700 /* Get the operator. */
1701 op = car(expr);
1702 if (!symbolp(op)) {
1703 run_warning("Attempted to evaluate a bad arithmetic expression.");
1704 return lispnil;
1705 }
1706 /* Determine which operator we are dealing with. */
1707 opcode = (enum keywords) keyword_code(c_string(op));
1708 /* Error, if an unexpected symbol is encountered. */
1709 if ((K_PLUS != opcode) && (K_MINUS != opcode)
1710 && (K_MULTIPLY != opcode) && (K_DIVIDE != opcode)) {
1711 run_warning("Attempted to evaluate a bad arithmetic expression.");
1712 return lispnil;
1713 }
1714 for_all_list(cdr(expr),opnds) {
1715 opnd2 = car(opnds);
1716 /* Skip empty operands. */
1717 if (lispnil == opnd2)
1718 continue;
1719 /* Replace symbols with their values. May expand to lists or numbers. */
1720 if (symbolp(opnd2))
1721 opnd2 = eval_symbol(opnd2);
1722 /* Evaluate any lists which may contain arithmetic expressions. */
1723 if (consp(opnd2) && symbolp(car(opnd2)))
1724 opnd2 = eval(opnd2);
1725 /* Error, if the second operand is neither a number nor a list. */
1726 if (!numberp(opnd2) && !consp(opnd2)) {
1727 run_warning(
1728 "Attempted to evaluate illegal operand in artithmetic expression.");
1729 return lispnil;
1730 }
1731 /* Set the operand length, if not already set. */
1732 if (!opndlength && consp(opnd2))
1733 opndlength = length(opnd2);
1734 /* Error, if there is a list length mismatch. */
1735 if (opndlength && consp(opnd2) && (opndlength != length(opnd2))) {
1736 run_warning(
1737 "Attempted to evaluate arithmetic expression with unmatched list lengths.");
1738 return lispnil;
1739 }
1740 /* Shift the operands, if the first one is an empty list. */
1741 if (lispnil == opnd) {
1742 opnd = opnd2;
1743 continue;
1744 }
1745 /* Do the actual work. */
1746 operated = TRUE;
1747 if ((lispnil == rslt) && numberp(opnd))
1748 rslt = new_number(c_number(opnd));
1749 /* Operating a number with... */
1750 if (numberp(rslt)) {
1751 /* ...a number. */
1752 if (numberp(opnd2)) {
1753 switch (opcode) {
1754 case K_PLUS:
1755 rslt->v.num += opnd2->v.num;
1756 break;
1757 case K_MINUS:
1758 rslt->v.num -= opnd2->v.num;
1759 break;
1760 case K_MULTIPLY:
1761 rslt->v.num *= opnd2->v.num;
1762 break;
1763 case K_DIVIDE:
1764 if (opnd2->v.num)
1765 rslt->v.num /= opnd2->v.num;
1766 /* Divide-by-zero error. */
1767 else {
1768 run_warning(
1769 "Attempted to evaluate arithmetic expression with division by zero.");
1770 return lispnil;
1771 }
1772 break;
1773 default:
1774 run_warning(
1775 "Attempted to evaluate a bad arithmetic expression.");
1776 return lispnil;
1777 }
1778 }
1779 /* ...a list. */
1780 else {
1781 /* Hold the outermost result. */
1782 tmprslt = eval(cons(op, cons(rslt, cons(car(opnd2), lispnil))));
1783 /* Wittle down the list recursively in an order preserving
1784 manner. */
1785 if (lispnil != cdr(opnd2))
1786 rslt = cons(tmprslt,
1787 cons(eval(cons(op, cons(rslt, cdr(opnd2)))),
1788 lispnil));
1789 /* Exit condition. */
1790 else
1791 rslt = cons(tmprslt, lispnil);
1792 }
1793 }
1794 /* Operating a list with... */
1795 else {
1796 /* Do this so we don't have to do a deep copy of 'opnd' first
1797 time around. The deep copy will happen naturally, and we
1798 will end up with an initialized 'rslt'. Subsequently,
1799 'opnd' will be irrelevant, and we can thus clobber it with
1800 'rslt'. */
1801 if (lispnil != rslt)
1802 opnd = rslt;
1803 /* ...a number. */
1804 if (numberp(opnd2)) {
1805 /* Hold the outermost result. */
1806 tmprslt = eval(cons(op, cons(car(opnd), cons(opnd2, lispnil))));
1807 /* Wittle down the list recursively in an order preserving
1808 manner. */
1809 if (lispnil != cdr(opnd))
1810 rslt = cons(tmprslt,
1811 eval(cons(op,
1812 cons(cdr(opnd),
1813 cons(opnd2, lispnil)))));
1814 /* Exit condition. */
1815 else
1816 rslt = cons(tmprslt, lispnil);
1817 }
1818 /* ...a list. */
1819 else {
1820 /* Hold the outermost result. */
1821 tmprslt = eval(cons(op,
1822 cons(car(opnd),
1823 cons(car(opnd2), lispnil))));
1824 /* Wittle down the list recursively in an order preserving
1825 manner. */
1826 if (lispnil != cdr(opnd)) /* The same for 'opnd2'. */
1827 rslt = cons(tmprslt,
1828 eval(cons(op,
1829 cons(cdr(opnd),
1830 cons(cdr(opnd2), lispnil)))));
1831 else
1832 rslt = cons(tmprslt, lispnil);
1833 }
1834 }
1835 }
1836 if (!operated) {
1837 if (opnd == lispnil) {
1838 /* Return identities for "+" and "*", per Common Lisp standard. */
1839 if (K_PLUS == opcode)
1840 rslt = new_number(0);
1841 else if (K_MULTIPLY == opcode)
1842 rslt = new_number(1);
1843 /* Else, give error. */
1844 else {
1845 run_warning(
1846 "Attempted to evaluate an arithmetic expression with too few operands.");
1847 return lispnil;
1848 }
1849 }
1850 /* (The behavior of divide differs from Common Lisp in this case;
1851 Clisp will take the reciprocal and return a rational number;
1852 GDL currently does not have rational numbers.) */
1853 if (opnd != lispnil) {
1854 /* If plus, then return the operand unchanged. */
1855 if (K_PLUS == opcode)
1856 rslt = opnd;
1857 /* If minus, then return the negation of the operand. */
1858 else if (K_MINUS == opcode)
1859 rslt = eval(cons(op, cons(new_number(0), cons(opnd, lispnil))));
1860 /* Else, give error. */
1861 else {
1862 run_warning(
1863 "Attempted to evaluate an arithmetic expression with too few operands.");
1864 return lispnil;
1865 }
1866 }
1867 }
1868 return rslt;
1869 }
1870
1871 /* Evaluate an arithmetic expression like Common Lisp. */
1872
1873 Obj *
eval_arithmetic_comparison_expression(Obj * expr)1874 eval_arithmetic_comparison_expression(Obj *expr)
1875 {
1876 enum keywords opcode;
1877 Obj *op = lispnil, *opnds = lispnil, *opnd = lispnil, *opnd2 = lispnil;
1878 Obj *retobj = lispnil;
1879
1880 /* If expression is empty, then warn and get out. */
1881 if (lispnil == expr) {
1882 run_warning(
1883 "Attempted to evaluate a bad arithmetic comparison expression.");
1884 return lispnil;
1885 }
1886 /* Get the operator. */
1887 op = car(expr);
1888 if (!symbolp(op) || boundp(op)) {
1889 run_warning(
1890 "Attempted to evaluate a bad arithmetic comparison expression.");
1891 return lispnil;
1892 }
1893 /* Determine which operator we are dealing with. */
1894 opcode = (enum keywords) keyword_code(c_string(op));
1895 /* Error, if an unexpected symbol is encountered. */
1896 if ((K_EQ != opcode) && (K_NE != opcode) && (K_LT != opcode)
1897 && (K_LE != opcode) && (K_GT != opcode) && (K_GE != opcode)) {
1898 run_warning(
1899 "Attempted to evaluate a bad arithmetic comparison expression.");
1900 return lispnil;
1901 }
1902 /*! \todo Possibly make this as flexible as the arithmetic expression
1903 evaluator. */
1904 for_all_list(cdr(expr), opnds) {
1905 opnd2 = car(opnds);
1906 /* Skip empty operands. */
1907 if (lispnil == opnd2)
1908 continue;
1909 /* Expand any bound symbols. */
1910 if (symbolp(opnd2) && boundp(opnd2))
1911 opnd2 = eval_symbol(opnd2);
1912 if (lispnil == opnd2)
1913 continue;
1914 /* If list is encountered, attempt to evaluate it. */
1915 if (consp(opnd2))
1916 opnd2 = eval(opnd2);
1917 if (lispnil == opnd2)
1918 continue;
1919 /* If we do not have a number by this point, then we have a problem. */
1920 if (!numberp(opnd2)) {
1921 run_warning("Illegal operand encountered in arithmetic expression");
1922 return lispnil;
1923 }
1924 /* Compare, if we have something to compare against. */
1925 if (lispnil != opnd) {
1926 switch (opcode) {
1927 case K_EQ:
1928 if (c_number(opnd) != c_number(opnd2))
1929 return lispnil;
1930 break;
1931 case K_NE:
1932 if (c_number(opnd) == c_number(opnd2))
1933 return lispnil;
1934 break;
1935 case K_LT:
1936 if (c_number(opnd) >= c_number(opnd2))
1937 return lispnil;
1938 break;
1939 case K_LE:
1940 if (c_number(opnd) > c_number(opnd2))
1941 return lispnil;
1942 break;
1943 case K_GT:
1944 if (c_number(opnd) <= c_number(opnd2))
1945 return lispnil;
1946 break;
1947 case K_GE:
1948 if (c_number(opnd) < c_number(opnd2))
1949 return lispnil;
1950 break;
1951 default: break;
1952 }
1953 }
1954 /* Load current operand into previous operand slot. */
1955 opnd = opnd2;
1956 /* Set the retobj, if necessary. */
1957 if (lispnil == retobj)
1958 retobj = new_number(TRUE);
1959 }
1960 return retobj;
1961 }
1962
1963 /* Choose from a list of weights and values, which can be formatted as
1964 a flat list of (n1 v1 n2 v2 ...), or as ((n1 v1) (n2 v2) ...) */
1965
1966 Obj *
choose_from_weighted_list(Obj * lis,int * totalweightp,int flat)1967 choose_from_weighted_list(Obj *lis, int *totalweightp, int flat)
1968 {
1969 int n, sofar, weight;
1970 char buf[BUFSIZE];
1971 Obj *rest, *head, *tail, *rslt;
1972
1973 if (*totalweightp <= 0) {
1974 for_all_list(lis, rest) {
1975 if (flat) {
1976 if (numberp(car(rest))) {
1977 weight = c_number(car(rest));
1978 rest = cdr(rest);
1979 } else {
1980 weight = 1;
1981 }
1982 } else {
1983 head = car(rest);
1984 weight = ((consp(head) && numberp(car(head)))
1985 ? c_number(car(head)) : 1);
1986 }
1987 *totalweightp += weight;
1988 }
1989 }
1990 /* Warn about dubious weights - note that we can continue to
1991 execute, xrandom on 0 is still 0. */
1992 if (*totalweightp == 0) {
1993 sprintlisp(buf, lis, BUFSIZE);
1994 run_warning("Sum of weights in weighted list `%s' is 0", buf);
1995 }
1996 n = xrandom(*totalweightp);
1997 sofar = 0;
1998 rslt = lispnil;
1999 for_all_list(lis, rest) {
2000 if (flat) {
2001 if (numberp(car(rest))) {
2002 sofar += c_number(car(rest));
2003 rest = cdr(rest);
2004 } else {
2005 sofar += 1;
2006 }
2007 tail = car(rest);
2008 } else {
2009 head = car(rest);
2010 if (consp(head) && numberp(car(head))) {
2011 sofar += c_number(car(head));
2012 tail = cdr(head);
2013 } else {
2014 sofar += 1;
2015 tail = head;
2016 }
2017 }
2018 if (sofar > n) {
2019 rslt = tail;
2020 break;
2021 }
2022 }
2023 return rslt;
2024 }
2025
2026 int
interpolate_in_list(int val,Obj * lis,int * rslt)2027 interpolate_in_list(int val, Obj *lis, int *rslt)
2028 {
2029 int first, thisin, thisval, nextin, nextval;
2030 Obj *rest, *head, *next;
2031
2032 first = TRUE;
2033 for_all_list(lis, rest) {
2034 head = car(rest);
2035 thisin = c_number(car(head));
2036 thisval = c_number(cadr(head));
2037 if (cdr(rest) != lispnil) {
2038 next = cadr(rest);
2039 nextin = c_number(car(next));
2040 nextval = c_number(cadr(next));
2041 first = FALSE;
2042 } else if (first) {
2043 if (val == thisin) {
2044 *rslt = thisval;
2045 return 0;
2046 } else if (val < thisin) {
2047 return (-1);
2048 } else {
2049 return 1;
2050 }
2051 } else {
2052 /* We're at the end of a several-item list; the value
2053 must be too high. */
2054 return 1;
2055 }
2056 if (val < thisin) {
2057 return (-1);
2058 } else if (between(thisin, val, nextin)) {
2059 if (val == thisin) {
2060 *rslt = thisval;
2061 } else if (val == nextin) {
2062 *rslt = nextval;
2063 } else {
2064 *rslt = thisval;
2065 if (val != thisin && nextin != thisin) {
2066 /* Add the linear interpolation. */
2067 *rslt += ((nextval - thisval) * (val - thisin)) / (nextin - thisin);
2068 }
2069 }
2070 return 0;
2071 }
2072 }
2073 return (-1);
2074 }
2075
2076 int
interpolate_in_list_ext(int val,Obj * lis,int mindo,int minval,int minrslt,int maxdo,int maxval,int maxrslt,int * rslt)2077 interpolate_in_list_ext(int val, Obj *lis, int mindo, int minval, int minrslt,
2078 int maxdo, int maxval, int maxrslt, int *rslt)
2079 {
2080 int first, thisin, thisval, nextin, nextval;
2081 Obj *rest, *head, *next;
2082
2083 /* (should use the additional parameters) */
2084 first = TRUE;
2085 for_all_list(lis, rest) {
2086 head = car(rest);
2087 thisin = c_number(car(head));
2088 thisval = c_number(cadr(head));
2089 if (cdr(rest) != lispnil) {
2090 next = cadr(rest);
2091 nextin = c_number(car(next));
2092 nextval = c_number(cadr(next));
2093 first = FALSE;
2094 } else if (first) {
2095 if (val == thisin) {
2096 *rslt = thisval;
2097 return 0;
2098 } else if (val < thisin) {
2099 return (-1);
2100 } else {
2101 return 1;
2102 }
2103 } else {
2104 /* We're at the end of a several-item list; the value
2105 must be too high. */
2106 return 1;
2107 }
2108 if (val < thisin) {
2109 return (-1);
2110 } else if (between(thisin, val, nextin)) {
2111 if (val == thisin) {
2112 *rslt = thisval;
2113 } else if (val == nextin) {
2114 *rslt = nextval;
2115 } else {
2116 *rslt = thisval;
2117 if (val != thisin && nextin != thisin) {
2118 /* Add the linear interpolation. */
2119 *rslt += ((nextval - thisval) * (val - thisin)) / (nextin - thisin);
2120 }
2121 }
2122 return 0;
2123 }
2124 }
2125 return (-1);
2126 }
2127
2128 void
interp_short_array(short * arr,Obj * lis,int n)2129 interp_short_array(short *arr, Obj *lis, int n)
2130 {
2131 int i = 0;
2132 Obj *rest, *head;
2133
2134 /* Assume that if the destination array does not exist, there is
2135 probably a reason, and it's not our concern. */
2136 if (arr == NULL)
2137 return;
2138 for_all_list(lis, rest) {
2139 head = car(rest);
2140 if (numberp(head)) {
2141 if (i < n) {
2142 arr[i++] = c_number(head);
2143 } else {
2144 init_warning("too many numbers in list");
2145 break;
2146 }
2147 }
2148 }
2149 }
2150
2151 void
interp_long_array(long * arr,Obj * lis,int n)2152 interp_long_array(long *arr, Obj *lis, int n)
2153 {
2154 int i = 0;
2155 Obj *rest, *head;
2156
2157 /* Assume that if the destination array does not exist, there is
2158 probably a reason, and it's not our concern. */
2159 if (arr == NULL)
2160 return;
2161 for_all_list(lis, rest) {
2162 head = car(rest);
2163 if (numberp(head)) {
2164 if (i < n) {
2165 arr[i++] = c_number(head);
2166 } else {
2167 init_warning("too many numbers in list");
2168 break;
2169 }
2170 }
2171 }
2172 }
2173
2174 char *
get_string(Obj * lis)2175 get_string(Obj *lis)
2176 {
2177 char *str = NULL;
2178
2179 if (lis != lispnil) {
2180 if (stringp(lis)) {
2181 str = c_string(lis);
2182 } else if (consp(lis)) {
2183 if (stringp(car(lis))) {
2184 str = c_string(car(lis));
2185 }
2186 }
2187 }
2188 return str;
2189 }
2190
2191