1 /*
2 * Filename: slisp_eval.c
3 * Author : matt@lanl.gov
4 * Created : 19 Mar 2003
5 */
6
7 #include <stdlib.h>
8 #include <assert.h>
9 #include <string.h>
10 #include <math.h>
11 #include "slisp.h"
12 #include "slisp_store.h"
13 #include "sexp.h"
14
15 /**
16 * tokens for operations
17 */
18 typedef enum {
19 /* binary logical operations */
20 SL_EQ, SL_GT, SL_LT, SL_NE, SL_GEQ, SL_LEQ,
21
22 /* unary logical operations */
23 SL_NOT,
24
25 /* mathematical operations, binary */
26 SL_PLUS, SL_MINUS, SL_MULT, SL_DIVIDE, SL_EXP,
27
28 /* mathematical operations, unary */
29 SL_SQRT,
30
31 /* list construction/separation */
32 SL_CONS, SL_CDR, SL_CAR,
33
34 /* function application over lists */
35 SL_FOLD, SL_MAP,
36
37 /* list sorting */
38 SL_SORT,
39
40 /* conditional */
41 SL_IF,
42
43 /* lambda */
44 SL_LAMBDA,
45
46 /* UNKNOWN : ERROR */
47 SL_UNKNOWN
48 } slisp_op_t;
49
50 /*
51 * types for expression elements
52 */
53 typedef enum {
54 SL_INT,
55 SL_FLOAT,
56 SL_STRING,
57 SL_SEXP,
58 SL_INVALID
59 } slisp_val_t;
60
61 /*
62 * return type from the internal eval
63 */
64 typedef enum {
65 SL_PRIMITIVE,
66 SL_CLOSURE
67 } sl_wrap_t;
68
69 /*
70 * wrapper around primitive values and closures
71 */
72 typedef struct sexp_wrapper {
73 sl_wrap_t ty;
74 sexp_t *sx;
75 slisp_store_t *store;
76 } sexp_wrap_t;
77
dump_sexp_t(sexp_t * s)78 void dump_sexp_t(sexp_t *s) {
79 fprintf(stderr,"\n");
80 fprintf(stderr,"s=0x%x\n",(unsigned int)s);
81 fprintf(stderr,"s->ty=%d (",s->ty);
82 if (s->ty == SEXP_VALUE) fprintf(stderr,"SEXP_VALUE)\n");
83 else fprintf(stderr,"SEXP_LIST)\n");
84 fprintf(stderr,"s->aty=%d\n",s->aty);
85 fprintf(stderr,"s->val=0x%x (",(unsigned int)s->val);
86 if (s->val != NULL)
87 fprintf(stderr,"%s",s->val);
88 fprintf(stderr,")\n");
89 fprintf(stderr,"s->next=0x%x\n",(unsigned int)s->next);
90 fprintf(stderr,"s->list=0x%x\n",(unsigned int)s->list);
91 }
92
93 /**
94 * Given a sexp_t element, return the token that it represents.
95 */
tokenize(sexp_t * sx)96 slisp_op_t tokenize(sexp_t *sx) {
97 if (sx->ty != SEXP_VALUE) {
98 return SL_UNKNOWN;
99 }
100
101 if (strcmp("+",sx->val) == 0) return SL_PLUS;
102 else if (strcmp("-",sx->val) == 0) return SL_MINUS;
103 else if (strcmp("*",sx->val) == 0) return SL_MULT;
104 else if (strcmp("/",sx->val) == 0) return SL_DIVIDE;
105 else if (strcmp("^",sx->val) == 0) return SL_EXP;
106 else if (strcmp("=",sx->val) == 0) return SL_EQ;
107 else if (strcmp(">",sx->val) == 0) return SL_GT;
108 else if (strcmp("<",sx->val) == 0) return SL_LT;
109 else if (strcmp("<=",sx->val) == 0) return SL_LEQ;
110 else if (strcmp(">=",sx->val) == 0) return SL_GEQ;
111 else if (strcmp("<>",sx->val) == 0) return SL_NE;
112 else if (strcmp("if",sx->val) == 0) return SL_IF;
113 else if (strcmp("not",sx->val) == 0) return SL_NOT;
114 else if (strcmp("cdr",sx->val) == 0) return SL_CDR;
115 else if (strcmp("car",sx->val) == 0) return SL_CAR;
116 else if (strcmp("map",sx->val) == 0) return SL_MAP;
117 else if (strcmp("cons",sx->val) == 0) return SL_CONS;
118 else if (strcmp("fold",sx->val) == 0) return SL_FOLD;
119 else if (strcmp("sort",sx->val) == 0) return SL_SORT;
120 else if (strcmp("sqrt",sx->val) == 0) return SL_SQRT;
121 else if (strcmp("lambda",sx->val) == 0) return SL_LAMBDA;
122
123 return SL_UNKNOWN;
124 }
125
126 /**
127 * Given an expression element, try to derive the type.
128 */
derive_type(sexp_t * sx)129 slisp_val_t derive_type(sexp_t *sx) {
130 slisp_val_t ty = SL_INT;
131 char *p;
132
133 if (sx->ty == SEXP_LIST) return SL_SEXP;
134 p = sx->val;
135
136 if (p == NULL) return SL_INVALID;
137
138 /* only one minus, first character, is allowed while still remaining a
139 numeric type. */
140 if (p[0] == '-') p++;
141
142 while (p[0] != '\0' && ty != SL_STRING) {
143 if (p[0] == '.') {
144 if (ty == SL_INT) ty = SL_FLOAT;
145 else ty = SL_STRING;
146 } else if (p[0] > '9'|| p[0] < '0') ty = SL_STRING;
147 p++;
148 }
149
150 return ty;
151 }
152
153 #define NUMBUFSIZE 30
154
155 /**************************************/
156 /** macros to keep eval code cleaner **/
157 /**************************************/
158
159 #define CHECK_ARGS(arity,num,_op) if((arity)+1 != (num)) { fprintf(stderr,"OPERATOR %d REQUIRING %d ARGUMENTS RECEIVED %d\n",(_op),(arity),(num)-1); return NULL; }
160
161 #define CHECK_NUMERIC_TYPE(ty_arg) if ((ty_arg) == SL_INVALID || (ty_arg) == SL_STRING) { fprintf(stderr,"CANNOT PERFORM OPERATION ON NON-NUMERIC TYPES (%s:%d)\n",__FILE__,__LINE__); return NULL; }
162
163 #define SQUOTE_EVAL(sx,tmp) if ((sx)->ty == SEXP_VALUE && (sx)->aty == SEXP_SQUOTE) { (tmp)=parse_sexp((sx)->val,strlen((sx)->val)); destroy_sexp((sx)); (sx)=(tmp); (tmp)=NULL;}
164
165 #define CHECK_NONZERO(sx) if (strtod((sx)->val,NULL) == 0.0) { fprintf(stderr,"VALUE MUST BE NON-ZERO\n"); return NULL; }
166
167 #define CHECK_NONNEGATIVE(sx) if (strtod((sx)->val,NULL) < 0.0) { fprintf(stderr,"VALUE MUST BE NON-NEGATIVE\n"); return NULL; }
168
169 /**************************************/
170 /**************************************/
171 /**************************************/
172
173
174 /**
175 * Allocate a new sexp_t element representing a list.
176 */
new_sexp_list(sexp_t * l)177 sexp_t *new_sexp_list(sexp_t *l) {
178 sexp_t *sx = sexp_t_allocate();
179
180 sx->ty = SEXP_LIST;
181
182 sx->list = l;
183 sx->next = NULL;
184
185 sx->val = NULL;
186 sx->val_used = sx->val_allocated = 0;
187
188 return sx;
189 }
190
191 /**
192 * allocate a new sexp_t element representing a value
193 */
new_sexp(char * buf,int bs)194 sexp_t *new_sexp(char *buf, int bs) {
195 sexp_t *sx = sexp_t_allocate();
196
197 sx->ty = SEXP_VALUE;
198
199 sx->val = (char *)malloc(sizeof(char)*(bs+1));
200 assert(sx->val != NULL);
201
202 sx->val_used = sx->val_allocated = bs+1;
203
204 strcpy(sx->val,buf);
205
206 sx->list = sx->next = NULL;
207
208 #ifdef _DEBUG_
209 dump_sexp_t(sx);
210 #endif /* _DEBUG_ */
211
212 return sx;
213 }
214
_slisp_eval(sexp_t * sx,slisp_store_t * store)215 sexp_t *_slisp_eval(sexp_t *sx, slisp_store_t *store) {
216 slisp_op_t op;
217 int mult = 1;
218 char numbuf[NUMBUFSIZE];
219 sexp_t *sx_a, *sx_b, *tmp_sx;
220 slisp_val_t ty_a, ty_b;
221 int len, d;
222 #ifdef _DEBUG_
223 char debugbuf[BUFSIZ];
224 #endif /* _DEBUG_ */
225
226 /* NULL returns NULL */
227 if (sx == NULL) {
228 #ifdef _DEBUG_
229 fprintf(stderr,"_slisp_eval passed null sx\n");
230 #endif /* _DEBUG_ */
231 return NULL;
232 }
233
234 #ifdef _DEBUG_
235 printf("_slisp_eval: sx=0x%x\n",sx);
236 dump_sexp_t(sx);
237 print_sexp(debugbuf,BUFSIZ,sx);
238 printf("=======>%s\n",debugbuf);
239 #endif /* _DEBUG_ */
240
241 /* values evaluate to themselves or whatever variable they're bound to */
242 if (sx->ty == SEXP_VALUE) {
243 if (store->vmap == NULL)
244 return copy_sexp(sx);
245
246 // d=store->scope_depth;
247
248 sx_a = get_variable(sx->val,store,store->scope_depth);
249
250 if (sx_a == NULL)
251 return copy_sexp(sx);
252 else {
253 d = store->scope_depth - 1;
254
255 sx_b = get_variable(sx_a->val,store,d);
256 if (sx_b != NULL) {
257 destroy_sexp(sx_a);
258 sx_a = sx_b;
259 d--;
260 }
261
262 #ifdef _DEBUG_
263 print_sexp(debugbuf,BUFSIZ,sx_a);
264 fprintf(stderr,"GOT: %s\n",debugbuf);
265 #endif /* _DEBUG_ */
266
267 return sx_a;
268 }
269 }
270
271 #ifdef _DEBUG_
272 printf("_slisp_eval: pointing at list...\n");
273 dump_sexp_t(sx->list);
274 #endif /* _DEBUG_ */
275
276 if (sx->list->ty == SEXP_LIST)
277 return _slisp_eval(sx->list,store);
278
279 len = sexp_list_length(sx);
280 op = tokenize(sx->list);
281
282 #ifdef _DEBUG_
283 fprintf(stderr,"----> OPERATION %d (%s)\n",op,sx->list->val);
284 #endif /* _DEBUG_ */
285
286 switch (op) {
287 /* LOGICAL OPERATIONS */
288 /** unary **/
289 case SL_NOT:
290 CHECK_ARGS(1,len,op);
291
292 sx_a = _slisp_eval(sx->list->next,store);
293
294 if (sx_a->ty == SEXP_VALUE && strcmp(sx_a->val,"t") == 0)
295 sprintf(numbuf,"f");
296 else
297 sprintf(numbuf,"t");
298
299 destroy_sexp(sx_a);
300
301 return new_sexp(numbuf,strlen(numbuf));
302 break;
303
304 /** binary **/
305 case SL_EQ:
306 case SL_LEQ:
307 case SL_GEQ:
308 case SL_NE:
309 case SL_GT:
310 case SL_LT:
311 CHECK_ARGS(2,len,op);
312
313 sx_a = _slisp_eval(sx->list->next,store);
314 sx_b = _slisp_eval(sx->list->next->next,store);
315 ty_a = derive_type(sx_a);
316 ty_b = derive_type(sx_b);
317
318 if (ty_a == SL_SEXP || ty_b == SL_SEXP) {
319 fprintf(stderr,"BOOLEAN TESTS REQUIRE NON-LIST OPERANDS.\n");
320 return NULL;
321 }
322
323 if (ty_a != ty_b)
324 sprintf(numbuf,"f");
325 else {
326
327 switch(op) {
328 case SL_EQ:
329 if (strcmp(sx_a->val,sx_b->val) == 0)
330 sprintf(numbuf,"t");
331 else
332 sprintf(numbuf,"f");
333 break;
334
335 case SL_NE:
336 if (strcmp(sx_a->val,sx_b->val) != 0)
337 sprintf(numbuf,"t");
338 else
339 sprintf(numbuf,"f");
340 break;
341
342 case SL_GEQ:
343 if (ty_a == SL_STRING) {
344 if (strcmp(sx_a->val,sx_b->val) >= 0)
345 sprintf(numbuf,"t");
346 else
347 sprintf(numbuf,"f");
348 } else {
349 if (strtod(sx_a->val,NULL) >= strtod(sx_b->val,NULL))
350 sprintf(numbuf,"t");
351 else
352 sprintf(numbuf,"f");
353 }
354 break;
355
356 case SL_LEQ:
357 if (ty_a == SL_STRING) {
358 if (strcmp(sx_a->val,sx_b->val) <= 0)
359 sprintf(numbuf,"t");
360 else
361 sprintf(numbuf,"f");
362 } else {
363 if (strtod(sx_a->val,NULL) <= strtod(sx_b->val,NULL))
364 sprintf(numbuf,"t");
365 else
366 sprintf(numbuf,"f");
367 }
368 break;
369
370 case SL_GT:
371 if (ty_a == SL_STRING) {
372 if (strcmp(sx_a->val,sx_b->val) > 0)
373 sprintf(numbuf,"t");
374 else
375 sprintf(numbuf,"f");
376 } else {
377 if (strtod(sx_a->val,NULL) > strtod(sx_b->val,NULL))
378 sprintf(numbuf,"t");
379 else
380 sprintf(numbuf,"f");
381 }
382 break;
383
384 case SL_LT:
385 if (ty_a == SL_STRING) {
386 if (strcmp(sx_a->val,sx_b->val) < 0)
387 sprintf(numbuf,"t");
388 else
389 sprintf(numbuf,"f");
390 } else {
391 if (strtod(sx_a->val,NULL) < strtod(sx_b->val,NULL))
392 sprintf(numbuf,"t");
393 else
394 sprintf(numbuf,"f");
395 }
396 break;
397
398 default:
399 fprintf(stderr,"THIS SHOULD NEVER HAPPEN!\n");
400 return NULL;
401 }
402 }
403
404 destroy_sexp(sx_a);
405 destroy_sexp(sx_b);
406
407 return new_sexp(numbuf,strlen(numbuf));
408 break;
409
410 /* MINUS and PLUS */
411 case SL_MINUS:
412 mult = -1;
413 case SL_PLUS:
414 CHECK_ARGS(2,len,op);
415
416 sx_a = _slisp_eval(sx->list->next,store);
417 sx_b = _slisp_eval(sx->list->next->next,store);
418 ty_a = derive_type(sx_a);
419 ty_b = derive_type(sx_b);
420
421 CHECK_NUMERIC_TYPE(ty_a);
422 CHECK_NUMERIC_TYPE(ty_b);
423
424 /* float */
425 if (ty_a == SL_FLOAT || ty_b == SL_FLOAT)
426 sprintf(numbuf,"%f",(strtod(sx_a->val,NULL) +
427 ((double)mult * strtod(sx_b->val,NULL))));
428 /* int */
429 else
430 sprintf(numbuf,"%d",(atoi(sx_a->val) + (mult *atoi(sx_b->val))));
431
432 destroy_sexp(sx_a);
433 destroy_sexp(sx_b);
434
435 return new_sexp(numbuf,strlen(numbuf));
436 break;
437
438 /* DIVIDE and MULT */
439 case SL_DIVIDE:
440 case SL_MULT:
441 CHECK_ARGS(2,len,op);
442
443 sx_a = _slisp_eval(sx->list->next,store);
444 sx_b = _slisp_eval(sx->list->next->next,store);
445
446 if (sx_a == NULL || sx_b == NULL) dump_store(store);
447
448 assert(sx_a != NULL);
449 assert(sx_b != NULL);
450
451 ty_a = derive_type(sx_a);
452 ty_b = derive_type(sx_b);
453
454 CHECK_NUMERIC_TYPE(ty_a);
455 CHECK_NUMERIC_TYPE(ty_b);
456
457 if (op == SL_DIVIDE) CHECK_NONZERO(sx_b);
458
459 /* division */
460 if (op == SL_DIVIDE) {
461 sprintf(numbuf,"%f",(strtod(sx_a->val,NULL) /
462 strtod(sx_b->val,NULL)));
463 /* multiplication */
464 } else {
465 if (ty_a == SL_INT && ty_b == SL_INT)
466 sprintf(numbuf,"%d",(atoi(sx_a->val) * atoi(sx_b->val)));
467 else
468 sprintf(numbuf,"%f",(strtod(sx_a->val,NULL) *
469 strtod(sx_b->val,NULL)));
470 }
471
472 destroy_sexp(sx_a);
473 destroy_sexp(sx_b);
474
475 return new_sexp(numbuf,strlen(numbuf));
476 break;
477
478 case SL_EXP:
479 CHECK_ARGS(2,len,op);
480
481 sx_a = _slisp_eval(sx->list->next,store);
482 sx_b = _slisp_eval(sx->list->next->next,store);
483 ty_a = derive_type(sx_a);
484 ty_b = derive_type(sx_b);
485
486 CHECK_NUMERIC_TYPE(ty_a);
487 CHECK_NUMERIC_TYPE(ty_b);
488
489 if (strtod(sx_b->val,NULL) < 0.0) {
490 sprintf(numbuf,"%f",(pow(strtod(sx_a->val,NULL),
491 strtod(sx_b->val,NULL))));
492 } else {
493 if (ty_a == SL_INT && ty_b == SL_INT)
494 sprintf(numbuf,"%d",(int)(pow(strtod(sx_a->val,NULL),
495 strtod(sx_b->val,NULL))));
496 else
497 sprintf(numbuf,"%f",(pow(strtod(sx_a->val,NULL),
498 strtod(sx_b->val,NULL))));
499 }
500
501 destroy_sexp(sx_a);
502 destroy_sexp(sx_b);
503
504 return new_sexp(numbuf,strlen(numbuf));
505 break;
506
507 case SL_SQRT:
508 CHECK_ARGS(1,len,op);
509
510 sx_a = _slisp_eval(sx->list->next,store);
511 ty_a = derive_type(sx_a);
512
513 CHECK_NUMERIC_TYPE(ty_a);
514 CHECK_NONNEGATIVE(sx_a);
515
516 sprintf(numbuf,"%f",(sqrt(strtod(sx_a->val,NULL))));
517
518 destroy_sexp(sx_a);
519
520 return new_sexp(numbuf,strlen(numbuf));
521 break;
522
523 case SL_CDR:
524 case SL_CAR:
525 CHECK_ARGS(1,len,op);
526
527 sx_a = _slisp_eval(sx->list->next,store);
528
529 SQUOTE_EVAL(sx_a,tmp_sx);
530
531 if (sx_a->ty != SEXP_LIST) {
532 fprintf(stderr,"CANNOT PERFORM CAR ON NON-LIST EXPRESSION.\n");
533 return NULL;
534 }
535
536 if (op == SL_CAR) {
537 sx_b = copy_sexp(sx_a->list);
538 destroy_sexp(sx_a);
539 sx_a = sx_b;
540 sx_a->next = NULL;
541 } else {
542 sx_b = new_sexp_list(copy_sexp(sx_a->list->next));
543 sx_b->next = NULL;
544 destroy_sexp(sx_a);
545 sx_a = sx_b;
546 }
547
548 return sx_a;
549 break;
550
551 case SL_CONS:
552 CHECK_ARGS(2,len,op);
553
554 sx_a = _slisp_eval(sx->list->next,store);
555 sx_b = _slisp_eval(sx->list->next->next,store);
556
557 SQUOTE_EVAL(sx_a,tmp_sx);
558 SQUOTE_EVAL(sx_b,tmp_sx);
559
560 tmp_sx = new_sexp_list(sx_a);
561 if (sx_b->ty != SEXP_LIST)
562 tmp_sx->list->next = sx_b;
563 else
564 tmp_sx->list->next = sx_b->list;
565
566 return tmp_sx;
567 break;
568
569 case SL_IF:
570 CHECK_ARGS(3,len,op);
571
572 sx_a = _slisp_eval(sx->list->next,store);
573
574 if (sx_a->ty != SEXP_VALUE) {
575 fprintf(stderr,"IF REQUIRES BOOLEAN TEST\n");
576 return NULL;
577 }
578
579 if (strcmp(sx_a->val, "t") == 0) {
580 destroy_sexp(sx_a);
581 return _slisp_eval(sx->list->next->next,store);
582 } else {
583 destroy_sexp(sx_a);
584 return _slisp_eval(sx->list->next->next->next,store);
585 }
586
587 break;
588
589 case SL_LAMBDA:
590 if (len < 2) {
591 fprintf(stderr,"LAMBDA REQUIRES AT LEAST ONE ARGUMENT.\n");
592 return NULL;
593 }
594
595 /* no arguments */
596 if (len == 2) {
597 fprintf(stderr,"LAMBDA W/ NO ARGS\n");
598 }
599
600 /* walk to the last expression in the sequence */
601 sx_a = sx->list->next; /* arg1 name */
602 sx_b = sx->next; /* arg1 expression */
603 while (sx_a->next != NULL) {
604 #ifdef _DEBUG_
605 fprintf(stderr,"VAR:%s.\n",sx_a->val);
606 #endif /* _DEBUG_ */
607
608 if (sx_b == NULL) {
609 fprintf(stderr,"LAMBDA EXPRESSION REQUIRES MORE ARGUMENTS.\n");
610 return NULL;
611 }
612
613 tmp_sx = sx_b->next;
614 sx_b->next = NULL;
615 set_variable(sx_a->val,sx_b,store);
616 sx_b->next = tmp_sx;
617
618 sx_a = sx_a->next;
619 sx_b = sx_b->next;
620 }
621
622 while (sx_a->next != NULL) sx_a = sx_a->next;
623 tmp_sx = _slisp_eval(sx_a,store);
624
625 sx->next = NULL;
626 destroy_sexp(sx);
627
628 return tmp_sx;
629
630 break;
631
632 case SL_SORT:
633
634 case SL_FOLD:
635 case SL_MAP:
636
637 default:
638 fprintf(stderr,"UNKNOWN OPERATION %d (%s)\n",op,sx->list->val);
639 return NULL;
640 };
641 return NULL;
642 }
643
slisp_eval(sexp_t * sx)644 sexp_t *slisp_eval(sexp_t *sx) {
645 slisp_store_t *store = NULL;
646 sexp_t *ret = NULL;
647
648 store = init_store();
649
650 ret = _slisp_eval(copy_sexp(sx),store);
651
652 destroy_store(store);
653
654 return ret;
655 }
656