I have a very very crude hashtable-set! working. This will need to be converted...
[scheme] / src / libparser / scheme_funcs.c
1 #include <stdlib.h>
2
3 #include "core.h"
4 #include "scheme_funcs.h"
5 #include "util.h"
6
7 /* Create a new tuple object with a
8    given car and cdr */
9 object_type *cons(interp_core_type *interp, object_type *car,
10                   object_type *cdr) {
11     object_type *tuple=0;
12     
13     tuple=alloc_object(interp, TUPLE);
14     car(tuple)=car;
15     cdr(tuple)=cdr;
16     
17     return tuple;
18 }
19
20 /* Applies the quote symbol to an object */
21 object_type *quote(interp_core_type *interp, 
22                    object_type *obj) {
23
24     object_type *ret_val=0;
25     
26     /* Create a (quote ...) list */
27     /* and now (quote ( ... )) */
28
29     ret_val=cons(interp, interp->quote,
30                  cons(interp, obj, 0));
31     
32     return ret_val;
33 }
34
35 /* create an instance of a primitive object */
36 object_type *create_primitive(interp_core_type *interp, fn_type primitive,
37                               bool eval_first) {
38     object_type *obj=0;
39
40     obj=alloc_object(interp, PRIM);
41     obj->value.primitive.fn=primitive;
42     obj->value.primitive.eval_first=eval_first;
43     
44     return obj;
45 }
46
47 /* Bind a symbol to a given value */
48 void bind_symbol(interp_core_type *interp, object_type *sym, object_type *value) {
49     object_type *binding=0;
50     
51     /* Check to see if a binding exists, 
52        and replace it if it does */
53     binding=get_binding(interp, sym);
54     
55     if(binding) {
56         cdr(binding)=value;
57         return;
58     }
59
60     /* create a new binding as we didn't find one */
61     binding=cons(interp, sym, value);
62     
63     /* add our new binding to the list of bindings */
64     car(interp->env_stack)=cons(interp, binding, 
65                           car(interp->env_stack));
66 }
67
68 void bind_symbol_list(interp_core_type *interp, binding_type *binding_list) {
69     object_type *obj=0;
70     int i=0;
71
72     /* bind every symbol in the list of primitives */
73     for(i=0; binding_list[i].symbol!=0;i++) {
74         obj=create_symbol(interp, binding_list[i].symbol);
75         bind_symbol(interp, obj, 
76                     create_primitive(interp, binding_list[i].primitive, 
77                                      binding_list[i].eval_first));
78     }
79 }
80
81 object_type *get_binding(interp_core_type *interp, 
82                          object_type *sym) {
83     object_type *binding=0;
84     object_type *env=0;
85     object_type *list=0;
86
87     env=interp->env_stack;
88
89     /* Walk each environment */
90     while(env) {
91         list=car(env);
92         
93         /* walk every binding */
94         while(list) {
95             binding=car(list);
96             
97             /* we found the binding! */
98             if(car(binding)==sym) {
99                 return binding;
100             }
101             
102             list=cdr(list);
103         }
104         /* move to the next environment */
105         env=cdr(env);
106     }
107
108     return 0;
109 }
110
111 /* Is the interpreter currently in a runnable state? */
112 bool has_error(interp_core_type *interp) {
113     return interp->error;
114 }
115
116 /* Is this object self evaluating */
117 bool is_self_evaluating(interp_core_type *interp, object_type *obj) {
118     object_type_enum type=0;
119     type=obj->type;
120     
121     return type==FIXNUM || type==FLOATNUM 
122         || type==CHAR || type==BOOL
123         || type==STRING;
124 }
125
126 /* Is the object a quoted list? */
127 bool is_quoted(interp_core_type *interp,object_type *obj) {
128     
129     return obj!=0 && obj->type==TUPLE 
130         && car(obj)==interp->quote;
131 }
132
133 /* Is this list a procedure call */
134 bool is_tagged_list(interp_core_type *interp, 
135                        object_type *obj) {
136     return obj!=0 && obj->type==TUPLE
137         && car(obj)!=0 && car(obj)->type==SYM;
138 }
139
140 /* Is this is a primitive? */
141 bool is_primitive(interp_core_type *interp,
142                   object_type *obj) {
143     return obj!=0 && obj->type==PRIM;
144 }
145
146 /* Is this object a symbol */
147 bool is_symbol(interp_core_type *interp, object_type *obj) {
148     return obj!=0 && obj->type==SYM;
149 }
150
151 /* Check to see if the object represents truth */
152 bool is_true(interp_core_type *interp, object_type *obj) {
153     /* anything other than false is true */
154     return interp->boolean.false!=obj;
155 }
156
157 /* Primitives */
158
159 /* define */
160 object_type *prim_define(interp_core_type *interp, object_type *args) {
161     object_type *var=0;
162
163     /* make sure we have the correct arguments */
164     if(list_length(args)!=2) {
165         return interp->boolean.false;
166     }
167
168     /* You can bind a symbol or a 
169        special list */
170     if(!is_symbol(interp, car(args)) &&
171        !is_tagged_list(interp, car(args))) {
172         return interp->boolean.false;
173     }
174
175     var=car(args);
176
177     bind_symbol(interp, var, eval(interp, cdar(args)));
178
179     return interp->boolean.true;
180 }
181
182 /* set! */
183 object_type *prim_set(interp_core_type *interp, object_type *args) {
184     object_type *binding=0;
185
186     /* make sure we have the correct arguments */
187     if(list_length(args)!=2) {
188         return interp->boolean.false;
189     }
190
191     /* You can set the value of a symbol */
192     if(!is_symbol(interp, car(args))) {
193         return interp->boolean.false;
194     }
195
196     binding=get_binding(interp, car(args));
197     
198     if(binding==0) {
199         interp->error=1;
200         return interp->boolean.false;
201     }
202     
203     cdr(binding)=eval(interp, cdar(args));
204    
205     return interp->boolean.true;
206 }
207
208 /* quit */
209 object_type *prim_quit(interp_core_type *interp, object_type *args) {
210     cleanup_interp(interp);
211     exit(0);
212     return 0;
213 }
214
215 /* quote */
216 object_type *prim_quote(interp_core_type *interp, object_type *args) {
217     /* quote just says, don't evaluate my arguments */
218     if(list_length(args)<1) {
219         interp->error=1;
220         return interp->boolean.false;
221     }
222
223     return car(args);
224 }
225
226 /* An if then constrcut */
227 object_type *prim_if(interp_core_type *interp, object_type *args) {
228     object_type *predicate=0;
229     int arg_count=0;
230
231     /* make sure we have a predicate and at least
232        a then clause */
233     arg_count=list_length(args);
234     if(arg_count<2 || arg_count>3) {
235         interp->error=1;
236         return interp->boolean.false;
237     }
238     
239     /* evaluate the predicate */
240     predicate=eval(interp, car(args));
241
242     /* setup a tail call */
243     set_tail(interp);
244     
245     if(is_true(interp, predicate)) {
246         return cdar(args);
247     } else {
248         if(arg_count==2) {
249             return interp->boolean.false;
250         } else {
251             return cddar(args);
252         }
253     }
254 }
255
256 /* Converts a fixnum into a floatnum */
257 void fixnum_to_floatnum(interp_core_type *interp, object_type **num) {
258     object_type  *new_float=0;
259
260     /* We don't need to change anything here */
261     if((*num)->type==FLOATNUM) {
262         return;
263     }
264     
265     /* convert our int to a float */
266     new_float=alloc_object(interp, FLOATNUM);
267     new_float->value.float_val=(*num)->value.int_val;
268     (*num)=new_float;
269 }
270
271 /* Convert numbers into a mutually acceptable representation */
272 void normalize_numbers(interp_core_type *interp, object_type **num, 
273                        object_type **num2) {
274
275     if((*num)->type!=(*num2)->type) {
276         fixnum_to_floatnum(interp, num);
277         fixnum_to_floatnum(interp, num);
278     }
279 }
280
281 /* Math in Macros */
282 #define OPERATION(oper, name)                                           \
283     object_type *name(interp_core_type *interp, object_type *args) {    \
284         object_type *result=0;                                          \
285         object_type *operand=0;                                         \
286                                                                         \
287         int arg_count=0;                                                \
288                                                                         \
289                                                                         \
290         /* No argument means we return 0 */                             \
291         if(args==0) {                                                   \
292             result=alloc_object(interp, FIXNUM);                        \
293             result->value.int_val=0;                                    \
294             return result;                                              \
295         }                                                               \
296                                                                         \
297         /* clone the first argument into a new number for our result */ \
298         result=clone(interp, car(args));                                \
299         args=cdr(args);                                                 \
300                                                                         \
301         /* walk argument list and evaluate each one */                  \
302         while(args!=0) {                                                \
303             operand=car(args);                                          \
304                                                                         \
305             /* Make sure that everything is the same kind of number */  \
306             normalize_numbers(interp, &result, &operand);               \
307                                                                         \
308                                                                         \
309             /* Make sure to operate on the right field */               \
310             switch(result->type) {                                      \
311             case FIXNUM:                                                \
312                 result->value.int_val oper operand->value.int_val;      \
313                 break;                                                  \
314             case FLOATNUM:                                              \
315                 result->value.float_val oper operand->value.float_val;  \
316                 break;                                                  \
317             }                                                           \
318                                                                         \
319             args=cdr(args);                                             \
320         }                                                               \
321                                                                         \
322         return result;                                                  \
323     }                                                                   \
324
325 OPERATION(+=, prim_plus);
326 OPERATION(-=, prim_minus);
327 OPERATION(*=, prim_multi);
328 OPERATION(/=, prim_div);
329
330 /* Setup scheme primitive function bindings */
331 binding_type primitive_list[]={
332     {"define", &prim_define, 0},
333     {"set!", &prim_set, 0},
334     {"quit", &prim_quit, 0},
335     {"quote", &prim_quote, 0},
336     {"if", &prim_if, 0},
337
338     {"+", &prim_plus, 1},
339     {"-", &prim_minus, 1},
340     {"*", &prim_multi, 1},
341     {"/", &prim_div, 1},
342     {0,0} /* Terminate the list */
343 };