1 /**
2
3 SFSEXP: Small, Fast S-Expression Library version 1.0
4 Written by Matthew Sottile (matt@lanl.gov)
5
6 Copyright (2003-2006). The Regents of the University of California. This
7 material was produced under U.S. Government contract W-7405-ENG-36 for Los
8 Alamos National Laboratory, which is operated by the University of
9 California for the U.S. Department of Energy. The U.S. Government has rights
10 to use, reproduce, and distribute this software. NEITHER THE GOVERNMENT NOR
11 THE UNIVERSITY MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES ANY
12 LIABILITY FOR THE USE OF THIS SOFTWARE. If software is modified to produce
13 derivative works, such modified software should be clearly marked, so as not
14 to confuse it with the version available from LANL.
15
16 Additionally, this library is free software; you can redistribute it and/or
17 modify it under the terms of the GNU Lesser General Public License as
18 published by the Free Software Foundation; either version 2.1 of the
19 License, or (at your option) any later version.
20
21 This library is distributed in the hope that it will be useful, but WITHOUT
22 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
23 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License
24 for more details.
25
26 You should have received a copy of the GNU Lesser General Public License
27 along with this library; if not, write to the Free Software Foundation,
28 Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, U SA
29
30 LA-CC-04-094
31
32 **/
33
34 #include "slisp.h"
35 #include "slisp_util.h"
36 #include "slisp_env.h"
37 #include "slisp_memman.h"
38 #include <assert.h>
39 #include <stdlib.h>
40 #include <string.h>
41 #include <math.h>
42
43 sexp_t *_slisp_eval(sexp_t *s, slisp_env_t *e);
44
slisp_eval(sexp_t * sx)45 sexp_t *slisp_eval(sexp_t *sx) {
46 /* return _slisp_eval(deep_copy_sexp(sx),NULL); */
47 return _slisp_eval(sx,NULL);
48 }
49
new_sexp_bool(int i)50 sexp_t *new_sexp_bool(int i) {
51 sexp_t *sx;
52 sx = (sexp_t *)malloc(sizeof(sexp_t));
53 assert(sx != NULL);
54 MEM_CHECKPOINT(sx);
55
56 sx->ty = SEXP_VALUE;
57 sx->aty = SEXP_BASIC;
58 sx->val_allocated = 2;
59 sx->val_used = 2;
60 sx->val = (char *)malloc(sizeof(char)*2);
61 assert(sx->val != NULL);
62
63 if (i == 1) sx->val[0] = 't';
64 else sx->val[0] = 'f';
65 sx->val[1] = '\0';
66
67 return sx;
68 }
69
70 #define SX_TRUE new_sexp_bool(1)
71 #define SX_FALSE new_sexp_bool(0)
72 #define SX_NIL new_sexp_atom("nil",4,SEXP_BASIC)
73
74 #ifdef _ENABLE_WARNINGS_
75 #define WARNING(str) fprintf(stderr,"WARNING::%s\n",(str));
76 #else
77 #define WARNING(str) { }
78 #endif
79
80 #define DEBUG(str) fprintf(stderr,"[%s:%d]::%s\n",__FILE__,__LINE__,(str));
81
82 /********
83 **
84 ** don't look at the macros below. they may cause illness, or an urge
85 ** to wring my neck. neither are recommended outcomes.
86 **
87 **/
88
89 /** typeless comparison operator. prevent duplication of code for SL_???
90 operators for each supported type. **/
91 #define COMPARE_OPERATOR(a,b,op) { switch((op)) { case SL_EQ: if ((a) == (b)) return SX_TRUE; else return SX_FALSE; break; case SL_NE: if ((a) != (b)) return SX_TRUE; else return SX_FALSE; case SL_GT: if ((a) > (b)) return SX_TRUE; else return SX_FALSE; case SL_LT: if ((a) < (b)) return SX_TRUE; else return SX_FALSE; case SL_GEQ: if ((a) >= (b)) return SX_TRUE; else return SX_FALSE; case SL_LEQ: if ((a) <= (b)) return SX_TRUE; else return SX_FALSE; default: break;} }
92
93 /** typeless arithmetic operator **/
94 #define ARITH_OPERATOR(a,b,c,op) { switch((op)) { case SL_PLUS: (c)=(a)+(b); break; case SL_MINUS: (c)=(a)-(b); break; case SL_MULT: (c)=(a)*(b); break; case SL_DIVIDE: (c)=(a)/(b); break; case SL_EXP: (c)=pow((double)(a),(double)(b)); break; default: break; } }
95
96 /**
97 ** Ok - you can look again.
98 **
99 ********/
100
101 /** evaluate if operations **/
eval_conditional(sexp_t * sx,slisp_env_t * env)102 sexp_t *eval_conditional(sexp_t *sx, slisp_env_t *env) {
103 sexp_t *tresult, *test, *tclause, *eclause;
104
105 test = sx->list->next;
106 if (test == NULL) {
107 DEBUG("bad if arguments.");
108 return NULL;
109 }
110 tclause = test->next;
111 if (tclause == NULL) {
112 DEBUG("bad then clause in if");
113 return NULL;
114 }
115 eclause = tclause->next;
116 /* this is optional. if it is null, return NULL. */
117
118 tresult = _slisp_eval(test,env);
119
120 if (tresult == NULL) {
121 DEBUG("conditional test evaluation error.");
122 return NULL;
123 }
124
125 if (tresult->aty != SEXP_VALUE) {
126 DEBUG("conditional test evaluated to non-primitive type.");
127 return NULL;
128 }
129
130 if (tresult->val_allocated > 1 && tresult->val[1] == '\0') {
131 if (tresult->val[0] == 't') {
132 destroy_sexp(tresult);
133 FREE_CHECKPOINT(tresult);
134 return _slisp_eval(tclause,env);
135 } else if (tresult->val[0] == 'f') {
136 destroy_sexp(tresult);
137 FREE_CHECKPOINT(tresult);
138 if (eclause == NULL) return SX_NIL;
139 else return _slisp_eval(eclause,env);
140 } else {
141 DEBUG("conditional test evaluated to non-boolean value.");
142 return NULL;
143 }
144 }
145
146 DEBUG("unknown error in conditional evaluation.");
147 return NULL;
148 }
149
150 /** evaluate binary operators **/
eval_binop(sexp_t * sx,slisp_op_t op,slisp_env_t * env)151 sexp_t *eval_binop(sexp_t *sx, slisp_op_t op, slisp_env_t *env) {
152 sexp_t *operator, *a1, *a2;
153 slisp_val_t t1, t2;
154 int i1, i2;
155 double f1, f2;
156 int reeval = 0x00;
157
158 operator = sx->list;
159 a1 = operator->next;
160 if (a1 == NULL) {
161 DEBUG("first argument of binary operator undefined.\n");
162 return NULL;
163 }
164
165 a2 = a1->next;
166 if (a2 == NULL) {
167 DEBUG("second argument of binary operator undefined.\n");
168 return NULL;
169 }
170
171 t1 = derive_type(a1);
172 t2 = derive_type(a2);
173
174 if (t1 == SL_SEXP) {
175 a1 = _slisp_eval(a1,env);
176 reeval |= 0x01;
177 t1 = derive_type(a1);
178 }
179
180 if (t2 == SL_SEXP) {
181 a2 = _slisp_eval(a2,env);
182 reeval |= 0x02;
183 t2 = derive_type(a2);
184 }
185
186 if (t1 != t2) {
187 WARNING("comparison between incompatible types always false.");
188 return SX_FALSE;
189 } else {
190 switch (t1) {
191 case SL_INT:
192 i1 = atoi(a1->val);
193 i2 = atoi(a2->val);
194
195 if (reeval != 0) {
196 if ((reeval & 0x01) == 0x01) {
197 destroy_sexp(a1);
198 FREE_CHECKPOINT(a1);
199 }
200 if ((reeval & 0x02) == 0x02) {
201 destroy_sexp(a2);
202 FREE_CHECKPOINT(a2);
203 }
204 }
205
206 COMPARE_OPERATOR(i1,i2,op);
207
208 break;
209
210 case SL_FLOAT:
211 f1 = strtod(a1->val,NULL);
212 f2 = strtod(a2->val,NULL);
213
214 if (reeval != 0) {
215 if ((reeval & 0x01) == 0x01) {
216 destroy_sexp(a1);
217 FREE_CHECKPOINT(a1);
218 }
219 if ((reeval & 0x02) == 0x02) {
220 destroy_sexp(a2);
221 FREE_CHECKPOINT(a2);
222 }
223 }
224
225 COMPARE_OPERATOR(f1,f2,op);
226
227 break;
228
229 case SL_STRING:
230 i1 = strcmp(a1->val,a2->val);
231 i2 = 0;
232
233 if (reeval != 0) {
234 if ((reeval & 0x01) == 0x01) {
235 destroy_sexp(a1);
236 FREE_CHECKPOINT(a1);
237 }
238 if ((reeval & 0x02) == 0x02) {
239 destroy_sexp(a2);
240 FREE_CHECKPOINT(a2);
241 }
242 }
243
244 COMPARE_OPERATOR(i1,i2,op);
245
246 break;
247
248 case SL_SEXP:
249 WARNING("comparison between sexp elements always false.");
250 return SX_FALSE;
251
252 break;
253 default:
254 DEBUG("never should be here!!!");
255 }
256 }
257
258 return SX_FALSE;
259 }
260
261 /** evaluate binary arithmetic **/
eval_binarith(sexp_t * sx,slisp_op_t op,slisp_env_t * env)262 sexp_t *eval_binarith(sexp_t *sx, slisp_op_t op, slisp_env_t *env) {
263 sexp_t *operator, *a1, *a2, *retval;
264 slisp_val_t t1, t2;
265 int i1, i2, ires;
266 double f1, f2, fres;
267 char cbuf[30];
268 int reeval = 0;
269
270 operator = sx->list;
271 a1 = operator->next;
272 if (a1 == NULL) {
273 DEBUG("first argument of binary operator undefined.\n");
274 return NULL;
275 }
276
277 a2 = a1->next;
278 if (a2 == NULL) {
279 DEBUG("second argument of binary operator undefined.\n");
280 return NULL;
281 }
282
283 t1 = derive_type(a1);
284 t2 = derive_type(a2);
285
286 if (t1 == SL_SEXP) {
287 a1 = _slisp_eval(a1,env);
288 t1 = derive_type(a1);
289 reeval |= 0x01;
290 }
291
292 if (t2 == SL_SEXP) {
293 a2 = _slisp_eval(a2,env);
294 t2 = derive_type(a2);
295 reeval |= 0x02;
296 }
297
298 if (t1 == SL_STRING || t2 == SL_STRING) {
299 DEBUG("cannot perform arithmetic on strings."); /* idiot */
300 return NULL;
301 }
302
303 if (t1 == SL_SEXP || t1 == SL_INVALID ||
304 t2 == SL_SEXP || t2 == SL_INVALID) {
305 DEBUG("invalid arguments for arithmetic operator.");
306 return NULL;
307 }
308
309 if (t1 == t2 && t1 == SL_INT) {
310 i1 = atoi(a1->val);
311 i2 = atoi(a2->val);
312
313 if (reeval != 0) {
314 if ((reeval & 0x01) == 0x01) {
315 destroy_sexp(a1);
316 FREE_CHECKPOINT(a1);
317 }
318 if ((reeval & 0x02) == 0x02) {
319 destroy_sexp(a2);
320 FREE_CHECKPOINT(a2);
321 }
322 }
323
324 ARITH_OPERATOR(i1,i2,ires,op);
325 sprintf(cbuf,"%d",ires);
326 retval = new_sexp_atom(cbuf,strlen(cbuf),SEXP_BASIC);
327 MEM_CHECKPOINT(retval);
328
329 return retval;
330 } else {
331 f1 = strtod(a1->val,NULL);
332 f2 = strtod(a2->val,NULL);
333
334 if (reeval != 0) {
335 if ((reeval & 0x01) == 0x01) {
336 destroy_sexp(a1);
337 FREE_CHECKPOINT(a1);
338 }
339 if ((reeval & 0x02) == 0x02) {
340 destroy_sexp(a2);
341 FREE_CHECKPOINT(a2);
342 }
343 }
344
345 ARITH_OPERATOR(f1,f2,fres,op);
346 sprintf(cbuf,"%f",fres);
347 retval = new_sexp_atom(cbuf,strlen(cbuf), SEXP_BASIC);
348 MEM_CHECKPOINT(retval);
349 return retval;
350 }
351
352 DEBUG("unknown error evaluating arithmetic operator.");
353 return NULL;
354 }
355
eval_listop(sexp_t * sx,slisp_op_t op,slisp_env_t * env)356 sexp_t *eval_listop(sexp_t *sx, slisp_op_t op, slisp_env_t *env) {
357 sexp_t *retval, *l1, *l2;
358
359 if (op == SL_CAR || op == SL_CDR) {
360 l1 = sx->list->next;
361 if (l1 == NULL) {
362 DEBUG("invalid argument for car/cdr");
363 return NULL;
364 }
365
366 l1 = _slisp_eval(l1,env);
367 if (l1->ty == SEXP_LIST ||
368 (l1->ty == SEXP_VALUE && l1->aty == SEXP_SQUOTE)) {
369 if (l1->ty == SEXP_VALUE && l1->aty == SEXP_SQUOTE) {
370 l1 = parse_sexp(l1->val,l1->val_used);
371 if (l1->ty != SEXP_LIST) {
372 DEBUG("car/cdr squote eval'd to non-list.");
373 return NULL;
374 }
375 }
376 if (op == SL_CAR) {
377 l2 = l1->list->next;
378 l1->list->next = NULL;
379 retval = deep_copy_sexp(l1->list);
380 l1->list->next = l2;
381 MEM_CHECKPOINT(retval);
382 return retval;
383 } else {
384 assert(l1->list != NULL);
385 retval = deep_copy_sexp(l1->list->next);
386 MEM_CHECKPOINT(retval);
387 return retval;
388 }
389 } else {
390 DEBUG("car/cdr argument must evaluate to a list.");
391 return NULL;
392 }
393 } else {
394 }
395
396 DEBUG("unknown error in eval_listop");
397 return NULL;
398 }
399
_slisp_eval(sexp_t * sx,slisp_env_t * env)400 sexp_t *_slisp_eval(sexp_t *sx, slisp_env_t *env) {
401 sexp_t *retval = NULL;
402 slisp_op_t op;
403 sexp_t *tmpsx;
404 double d; /* ??? */
405 char cbuf[30];
406 int reeval = 0;
407
408 assert(sx != NULL);
409
410 /* check type of element. if it is an atom, return it. otherwise, treat
411 lists as (function arg0 arg1 ... argn) */
412 if (sx->ty == SEXP_VALUE) {
413 retval = deep_copy_sexp(sx);
414 MEM_CHECKPOINT(retval);
415 return retval;
416 }
417
418 /* tokenize head of list */
419 op = tokenize(sx->list);
420 switch (op) {
421 case SL_EQ:
422 case SL_GT:
423 case SL_LT:
424 case SL_NE:
425 case SL_GEQ:
426 case SL_LEQ:
427 /** binary operator **/
428 return eval_binop(sx,op,env);
429 break;
430
431 case SL_NOT:
432 /** unary operator **/
433 tmpsx = sx->list->next;
434
435 if (tmpsx == NULL) {
436 DEBUG("argument error for unary not operator.");
437 return NULL;
438 }
439 if (tmpsx->ty == SEXP_LIST) {
440 reeval = 1;
441 tmpsx = _slisp_eval(tmpsx,env);
442 if (tmpsx->ty == SEXP_LIST) {
443 DEBUG("cannot evaluate not operator on list argument.");
444 return NULL;
445 }
446 }
447 if (tmpsx->val_allocated > 1 && tmpsx->val[1] == '\0') {
448 if (tmpsx->val[0] == 't') {
449 if (reeval == 1) {
450 destroy_sexp(tmpsx);
451 FREE_CHECKPOINT(tmpsx);
452 }
453 return SX_FALSE;
454 } else {
455 if (tmpsx->val[0] == 'f') {
456 if (reeval == 1) {
457 destroy_sexp(tmpsx);
458 FREE_CHECKPOINT(tmpsx);
459 }
460 return SX_TRUE;
461 } else {
462 DEBUG("invalid argument for not operator.");
463 if (reeval == 1) {
464 destroy_sexp(tmpsx);
465 FREE_CHECKPOINT(tmpsx);
466 }
467 return NULL;
468 }
469 }
470 }
471
472 DEBUG("error evaluating not operator.");
473 return NULL;
474
475 break;
476
477 case SL_PLUS:
478 case SL_MINUS:
479 case SL_MULT:
480 case SL_DIVIDE:
481 case SL_EXP:
482 /** binary arithmetic **/
483 return eval_binarith(sx,op,env);
484 break;
485
486 case SL_SQRT:
487 /** unary arithmetic **/
488 tmpsx = sx->list->next;
489 if (tmpsx == NULL) {
490 DEBUG("missing argument for sqrt.");
491 return NULL;
492 }
493
494 switch (derive_type(tmpsx)) {
495 case SL_INT:
496 case SL_FLOAT:
497 d = sqrt(strtod(tmpsx->val,NULL));
498 sprintf(cbuf,"%f",d);
499 tmpsx = new_sexp_atom(cbuf,30, SEXP_BASIC);
500 return tmpsx;
501 default:
502 DEBUG("bad type in sqrt");
503 return NULL;
504 }
505
506 DEBUG("unknown error in eval for sqrt.");
507 return NULL;
508 break;
509
510 case SL_CONS:
511 case SL_CDR:
512 case SL_CAR:
513 /** list stuff **/
514 return eval_listop(sx,op,env);
515 break;
516
517 case SL_FOLD:
518 case SL_MAP:
519 /** function application over lists **/
520 break;
521
522 case SL_SORT:
523 break;
524
525 case SL_IF:
526 return eval_conditional(sx,env);
527 break;
528
529 case SL_LAMBDA:
530 break;
531
532 default:
533 fprintf(stderr,"EVAL: unknown token\n");
534 }
535
536 return retval;
537 }
538