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