1 | /* |
---|
2 | * Abuse - dark 2D side-scrolling platform game |
---|
3 | * Copyright (c) 1995 Crack dot Com |
---|
4 | * |
---|
5 | * This software was released into the Public Domain. As with most public |
---|
6 | * domain software, no warranty is made or implied by Crack dot Com or |
---|
7 | * Jonathan Clark. |
---|
8 | */ |
---|
9 | |
---|
10 | #include "config.h" |
---|
11 | |
---|
12 | #include <stdio.h> |
---|
13 | #include <ctype.h> |
---|
14 | #include <stdlib.h> |
---|
15 | #include <string.h> |
---|
16 | #include <stdarg.h> |
---|
17 | |
---|
18 | #define TYPE_CHECKING 1 |
---|
19 | #include "bus_type.h" |
---|
20 | |
---|
21 | #include "lisp.h" |
---|
22 | #include "lisp_gc.h" |
---|
23 | #include "symbols.h" |
---|
24 | |
---|
25 | #ifdef NO_LIBS |
---|
26 | # include "fakelib.h" |
---|
27 | #else |
---|
28 | # include "status.h" |
---|
29 | # include "macs.h" |
---|
30 | # include "specs.h" |
---|
31 | # include "dprint.h" |
---|
32 | # include "cache.h" |
---|
33 | # include "dev.h" |
---|
34 | #endif |
---|
35 | |
---|
36 | /* To bypass the whole garbage collection issue of lisp I am going to have |
---|
37 | * separate spaces where lisp objects can reside. Compiled code and gloabal |
---|
38 | * variables will reside in permanant space. Eveything else will reside in |
---|
39 | * tmp space which gets thrown away after completion of eval. system |
---|
40 | * functions reside in permant space. */ |
---|
41 | |
---|
42 | bFILE *current_print_file=NULL; |
---|
43 | LispSymbol *lsym_root=NULL; |
---|
44 | long ltotal_syms=0; |
---|
45 | |
---|
46 | |
---|
47 | |
---|
48 | uint8_t *space[4], *free_space[4]; |
---|
49 | int space_size[4], print_level=0, trace_level=0, trace_print_level=1000; |
---|
50 | int total_user_functions; |
---|
51 | |
---|
52 | int current_space; // normally set to TMP_SPACE, unless compiling or other needs |
---|
53 | |
---|
54 | int break_level=0; |
---|
55 | |
---|
56 | void l1print(void *block) |
---|
57 | { |
---|
58 | if(!block || item_type(block) != L_CONS_CELL) |
---|
59 | { |
---|
60 | lprint(block); |
---|
61 | return; |
---|
62 | } |
---|
63 | |
---|
64 | dprintf("("); |
---|
65 | for( ; block && item_type(block) == L_CONS_CELL; block = CDR(block)) |
---|
66 | { |
---|
67 | void *a = CAR(block); |
---|
68 | if(item_type(a) == L_CONS_CELL) |
---|
69 | dprintf("[...]"); |
---|
70 | else |
---|
71 | lprint(a); |
---|
72 | } |
---|
73 | if (block) |
---|
74 | { |
---|
75 | dprintf(" . "); |
---|
76 | lprint(block); |
---|
77 | } |
---|
78 | dprintf(")"); |
---|
79 | } |
---|
80 | |
---|
81 | void where_print(int max_lev = -1) |
---|
82 | { |
---|
83 | dprintf("Main program\n"); |
---|
84 | if (max_lev==-1) max_lev=l_ptr_stack.son; |
---|
85 | else if (max_lev>=l_ptr_stack.son) max_lev=l_ptr_stack.son-1; |
---|
86 | |
---|
87 | for (int i=0;i<max_lev;i++) |
---|
88 | { |
---|
89 | dprintf("%d> ", i); |
---|
90 | lprint(*l_ptr_stack.sdata[i]); |
---|
91 | } |
---|
92 | } |
---|
93 | |
---|
94 | void print_trace_stack(int max_levels) |
---|
95 | { |
---|
96 | where_print(max_levels); |
---|
97 | } |
---|
98 | |
---|
99 | void lbreak(char const *format, ...) |
---|
100 | { |
---|
101 | break_level++; |
---|
102 | bFILE *old_file=current_print_file; |
---|
103 | current_print_file=NULL; |
---|
104 | char st[300]; |
---|
105 | va_list ap; |
---|
106 | va_start(ap, format); |
---|
107 | vsprintf(st, format, ap); |
---|
108 | va_end(ap); |
---|
109 | dprintf("%s\n", st); |
---|
110 | int cont=0; |
---|
111 | do |
---|
112 | { |
---|
113 | dprintf("type q to quit\n"); |
---|
114 | dprintf("%d. Break> ", break_level); |
---|
115 | dgets(st, 300); |
---|
116 | if (!strcmp(st, "c") || !strcmp(st, "cont") || !strcmp(st, "continue")) |
---|
117 | cont=1; |
---|
118 | else if (!strcmp(st, "w") || !strcmp(st, "where")) |
---|
119 | where_print(); |
---|
120 | else if (!strcmp(st, "q") || !strcmp(st, "quit")) |
---|
121 | exit(1); |
---|
122 | else if (!strcmp(st, "e") || !strcmp(st, "env") || !strcmp(st, "environment")) |
---|
123 | { |
---|
124 | dprintf("Enviorment : \nnot supported right now\n"); |
---|
125 | |
---|
126 | } |
---|
127 | else if (!strcmp(st, "h") || !strcmp(st, "help") || !strcmp(st, "?")) |
---|
128 | { |
---|
129 | dprintf("CLIVE Debugger\n"); |
---|
130 | dprintf(" w, where : show calling parents\n" |
---|
131 | " e, env : show enviroment\n" |
---|
132 | " c, cont : continue if possible\n" |
---|
133 | " q, quit : quits the program\n" |
---|
134 | " h, help : this\n"); |
---|
135 | } |
---|
136 | else |
---|
137 | { |
---|
138 | char const *s=st; |
---|
139 | do |
---|
140 | { |
---|
141 | void *prog=compile(s); |
---|
142 | p_ref r1(prog); |
---|
143 | while (*s==' ' || *s=='\t' || *s=='\r' || *s=='\n') s++; |
---|
144 | lprint(eval(prog)); |
---|
145 | } while (*s); |
---|
146 | } |
---|
147 | |
---|
148 | } while (!cont); |
---|
149 | current_print_file=old_file; |
---|
150 | break_level--; |
---|
151 | } |
---|
152 | |
---|
153 | void need_perm_space(char const *why) |
---|
154 | { |
---|
155 | if (current_space!=PERM_SPACE && current_space!=GC_SPACE) |
---|
156 | { |
---|
157 | lbreak("%s : action requires permanant space\n", why); |
---|
158 | exit(0); |
---|
159 | } |
---|
160 | } |
---|
161 | |
---|
162 | void *mark_heap(int heap) |
---|
163 | { |
---|
164 | return free_space[heap]; |
---|
165 | } |
---|
166 | |
---|
167 | void restore_heap(void *val, int heap) |
---|
168 | { |
---|
169 | free_space[heap] = (uint8_t *)val; |
---|
170 | } |
---|
171 | |
---|
172 | static int get_free_size(int which_space) |
---|
173 | { |
---|
174 | return space_size[which_space] |
---|
175 | - (free_space[which_space] - space[which_space]); |
---|
176 | } |
---|
177 | |
---|
178 | void *lmalloc(int size, int which_space) |
---|
179 | { |
---|
180 | return malloc(size); |
---|
181 | |
---|
182 | #ifdef WORD_ALIGN |
---|
183 | size=(size+3)&(~3); |
---|
184 | #endif |
---|
185 | |
---|
186 | if (size > get_free_size(which_space)) |
---|
187 | { |
---|
188 | int fart = 1; |
---|
189 | fprintf(stderr, "%i > %i !!!\n", size, get_free_size(which_space)); |
---|
190 | |
---|
191 | if (which_space == PERM_SPACE || which_space == TMP_SPACE) |
---|
192 | { |
---|
193 | collect_space(which_space); |
---|
194 | if (size <= get_free_size(which_space)) |
---|
195 | fart = 0; |
---|
196 | } |
---|
197 | |
---|
198 | if (fart) |
---|
199 | { |
---|
200 | lbreak("lisp: cannot malloc %d bytes in space #%d\n", size, which_space); |
---|
201 | exit(0); |
---|
202 | } |
---|
203 | fprintf(stderr, "%i <= %i\n", size, get_free_size(which_space)); |
---|
204 | } |
---|
205 | void *ret = (void *)free_space[which_space]; |
---|
206 | free_space[which_space] += size; |
---|
207 | return ret; |
---|
208 | } |
---|
209 | |
---|
210 | void *eval_block(void *list) |
---|
211 | { |
---|
212 | p_ref r1(list); |
---|
213 | void *ret=NULL; |
---|
214 | while (list) |
---|
215 | { |
---|
216 | ret=eval(CAR(list)); |
---|
217 | list=CDR(list); |
---|
218 | } |
---|
219 | return ret; |
---|
220 | } |
---|
221 | |
---|
222 | LispArray *new_lisp_1d_array(int size, void *rest) |
---|
223 | { |
---|
224 | p_ref r11(rest); |
---|
225 | size_t s=sizeof(LispArray)+size*sizeof(void *); |
---|
226 | if (s<8 + sizeof(intptr_t)) s=8 + sizeof(intptr_t); |
---|
227 | void *p=(LispArray *)lmalloc(s, current_space); |
---|
228 | ((LispArray *)p)->type=L_1D_ARRAY; |
---|
229 | ((LispArray *)p)->size=size; |
---|
230 | void **data=(void **)(((LispArray *)p)+1); |
---|
231 | memset(data, 0, size*sizeof(void *)); |
---|
232 | p_ref r1(p); |
---|
233 | |
---|
234 | if (rest) |
---|
235 | { |
---|
236 | void *x=eval(CAR(rest)); |
---|
237 | if (x==colon_initial_contents) |
---|
238 | { |
---|
239 | x=eval(CAR(CDR(rest))); |
---|
240 | data=(void **)(((LispArray *)p)+1); |
---|
241 | for (int i=0;i<size;i++, x=CDR(x)) |
---|
242 | { |
---|
243 | if (!x) |
---|
244 | { |
---|
245 | lprint(rest); |
---|
246 | lbreak("(make-array) incorrect list length\n"); |
---|
247 | exit(0); |
---|
248 | } |
---|
249 | data[i]=CAR(x); |
---|
250 | } |
---|
251 | if (x) { lprint(rest); lbreak("(make-array) incorrect list length\n"); exit(0); } |
---|
252 | } |
---|
253 | else if (x==colon_initial_element) |
---|
254 | { |
---|
255 | x=eval(CAR(CDR(rest))); |
---|
256 | data=(void **)(((LispArray *)p)+1); |
---|
257 | for (int i=0;i<size;i++) |
---|
258 | data[i]=x; |
---|
259 | } |
---|
260 | else |
---|
261 | { |
---|
262 | lprint(x); |
---|
263 | lbreak("Bad option argument to make-array\n"); |
---|
264 | exit(0); |
---|
265 | } |
---|
266 | } |
---|
267 | |
---|
268 | return ((LispArray *)p); |
---|
269 | } |
---|
270 | |
---|
271 | LispFixedPoint *new_lisp_fixed_point(int32_t x) |
---|
272 | { |
---|
273 | LispFixedPoint *p=(LispFixedPoint *)lmalloc(sizeof(LispFixedPoint), current_space); |
---|
274 | p->type=L_FIXED_POINT; |
---|
275 | p->x=x; |
---|
276 | return p; |
---|
277 | } |
---|
278 | |
---|
279 | |
---|
280 | LispObjectVar *new_lisp_object_var(int16_t number) |
---|
281 | { |
---|
282 | LispObjectVar *p=(LispObjectVar *)lmalloc(sizeof(LispObjectVar), current_space); |
---|
283 | p->type=L_OBJECT_VAR; |
---|
284 | p->number=number; |
---|
285 | return p; |
---|
286 | } |
---|
287 | |
---|
288 | |
---|
289 | struct LispPointer *new_lisp_pointer(void *addr) |
---|
290 | { |
---|
291 | if (addr==NULL) return NULL; |
---|
292 | LispPointer *p=(LispPointer *)lmalloc(sizeof(LispPointer), current_space); |
---|
293 | p->type=L_POINTER; |
---|
294 | p->addr=addr; |
---|
295 | return p; |
---|
296 | } |
---|
297 | |
---|
298 | struct LispChar *new_lisp_character(uint16_t ch) |
---|
299 | { |
---|
300 | LispChar *c=(LispChar *)lmalloc(sizeof(LispChar), current_space); |
---|
301 | c->type=L_CHARACTER; |
---|
302 | c->ch=ch; |
---|
303 | return c; |
---|
304 | } |
---|
305 | |
---|
306 | struct LispString *new_lisp_string(char const *string) |
---|
307 | { |
---|
308 | size_t size=sizeof(LispString)+strlen(string)+1; |
---|
309 | if (size<8 + sizeof(intptr_t)) size=8 + sizeof(intptr_t); |
---|
310 | |
---|
311 | LispString *s=(LispString *)lmalloc(size, current_space); |
---|
312 | s->type=L_STRING; |
---|
313 | char *sloc=((char *)s)+sizeof(LispString); |
---|
314 | strcpy(sloc, string); |
---|
315 | return s; |
---|
316 | } |
---|
317 | |
---|
318 | struct LispString *new_lisp_string(char const *string, int length) |
---|
319 | { |
---|
320 | size_t size=sizeof(LispString)+length+1; |
---|
321 | if (size<8 + sizeof(intptr_t)) size=8 + sizeof(intptr_t); |
---|
322 | LispString *s=(LispString *)lmalloc(size, current_space); |
---|
323 | s->type=L_STRING; |
---|
324 | char *sloc=((char *)s)+sizeof(LispString); |
---|
325 | memcpy(sloc, string, length); |
---|
326 | sloc[length]=0; |
---|
327 | return s; |
---|
328 | } |
---|
329 | |
---|
330 | struct LispString *new_lisp_string(int length) |
---|
331 | { |
---|
332 | size_t size=sizeof(LispString)+length; |
---|
333 | if (size<8 + sizeof(intptr_t)) size=8 + sizeof(intptr_t); |
---|
334 | LispString *s=(LispString *)lmalloc(size, current_space); |
---|
335 | s->type=L_STRING; |
---|
336 | char *sloc=((char *)s)+sizeof(LispString); |
---|
337 | strcpy(sloc, ""); |
---|
338 | return s; |
---|
339 | } |
---|
340 | |
---|
341 | #ifdef NO_LIBS |
---|
342 | LispUserFunction *new_lisp_user_function(void *arg_list, void *block_list) |
---|
343 | { |
---|
344 | p_ref r1(arg_list), r2(block_list); |
---|
345 | LispUserFunction *lu=(LispUserFunction *)lmalloc(sizeof(LispUserFunction), current_space); |
---|
346 | lu->type=L_USER_FUNCTION; |
---|
347 | lu->arg_list=arg_list; |
---|
348 | lu->block_list=block_list; |
---|
349 | return lu; |
---|
350 | } |
---|
351 | #else |
---|
352 | LispUserFunction *new_lisp_user_function(intptr_t arg_list, intptr_t block_list) |
---|
353 | { |
---|
354 | int sp=current_space; |
---|
355 | if (current_space!=GC_SPACE) |
---|
356 | current_space=PERM_SPACE; // make sure all functions get defined in permanant space |
---|
357 | |
---|
358 | LispUserFunction *lu=(LispUserFunction *)lmalloc(sizeof(LispUserFunction), current_space); |
---|
359 | lu->type=L_USER_FUNCTION; |
---|
360 | lu->alist=arg_list; |
---|
361 | lu->blist=block_list; |
---|
362 | |
---|
363 | current_space=sp; |
---|
364 | |
---|
365 | return lu; |
---|
366 | } |
---|
367 | #endif |
---|
368 | |
---|
369 | |
---|
370 | LispSysFunction *new_lisp_sys_function(int min_args, int max_args, int fun_number) |
---|
371 | { |
---|
372 | // sys functions should reside in permanant space |
---|
373 | LispSysFunction *ls=(LispSysFunction *)lmalloc(sizeof(LispSysFunction), |
---|
374 | current_space==GC_SPACE ? GC_SPACE : PERM_SPACE); |
---|
375 | ls->type=L_SYS_FUNCTION; |
---|
376 | ls->min_args=min_args; |
---|
377 | ls->max_args=max_args; |
---|
378 | ls->fun_number=fun_number; |
---|
379 | return ls; |
---|
380 | } |
---|
381 | |
---|
382 | LispSysFunction *new_lisp_c_function(int min_args, int max_args, int fun_number) |
---|
383 | { |
---|
384 | // sys functions should reside in permanant space |
---|
385 | LispSysFunction *ls=(LispSysFunction *)lmalloc(sizeof(LispSysFunction), |
---|
386 | current_space==GC_SPACE ? GC_SPACE : PERM_SPACE); |
---|
387 | ls->type=L_C_FUNCTION; |
---|
388 | ls->min_args=min_args; |
---|
389 | ls->max_args=max_args; |
---|
390 | ls->fun_number=fun_number; |
---|
391 | return ls; |
---|
392 | } |
---|
393 | |
---|
394 | LispSysFunction *new_lisp_c_bool(int min_args, int max_args, int fun_number) |
---|
395 | { |
---|
396 | // sys functions should reside in permanant space |
---|
397 | LispSysFunction *ls=(LispSysFunction *)lmalloc(sizeof(LispSysFunction), |
---|
398 | current_space==GC_SPACE ? GC_SPACE : PERM_SPACE); |
---|
399 | ls->type=L_C_BOOL; |
---|
400 | ls->min_args=min_args; |
---|
401 | ls->max_args=max_args; |
---|
402 | ls->fun_number=fun_number; |
---|
403 | return ls; |
---|
404 | } |
---|
405 | |
---|
406 | LispSysFunction *new_user_lisp_function(int min_args, int max_args, int fun_number) |
---|
407 | { |
---|
408 | // sys functions should reside in permanant space |
---|
409 | LispSysFunction *ls=(LispSysFunction *)lmalloc(sizeof(LispSysFunction), |
---|
410 | current_space==GC_SPACE ? GC_SPACE : PERM_SPACE); |
---|
411 | ls->type=L_L_FUNCTION; |
---|
412 | ls->min_args=min_args; |
---|
413 | ls->max_args=max_args; |
---|
414 | ls->fun_number=fun_number; |
---|
415 | return ls; |
---|
416 | } |
---|
417 | |
---|
418 | LispNumber *new_lisp_node(long num) |
---|
419 | { |
---|
420 | LispNumber *n=(LispNumber *)lmalloc(sizeof(LispNumber), current_space); |
---|
421 | n->type=L_NUMBER; |
---|
422 | n->num=num; |
---|
423 | return n; |
---|
424 | } |
---|
425 | |
---|
426 | LispSymbol *new_lisp_symbol(char *name) |
---|
427 | { |
---|
428 | LispSymbol *s=(LispSymbol *)lmalloc(sizeof(LispSymbol), current_space); |
---|
429 | s->type=L_SYMBOL; |
---|
430 | s->name=new_lisp_string(name); |
---|
431 | s->value=l_undefined; |
---|
432 | s->function=l_undefined; |
---|
433 | #ifdef L_PROFILE |
---|
434 | s->time_taken=0; |
---|
435 | #endif |
---|
436 | return s; |
---|
437 | } |
---|
438 | |
---|
439 | LispNumber *new_lisp_number(long num) |
---|
440 | { |
---|
441 | LispNumber *s=(LispNumber *)lmalloc(sizeof(LispNumber), current_space); |
---|
442 | s->type=L_NUMBER; |
---|
443 | s->num=num; |
---|
444 | return s; |
---|
445 | } |
---|
446 | |
---|
447 | |
---|
448 | LispList *new_cons_cell() |
---|
449 | { |
---|
450 | LispList *c=(LispList *)lmalloc(sizeof(LispList), current_space); |
---|
451 | c->type=L_CONS_CELL; |
---|
452 | c->car=NULL; |
---|
453 | c->cdr=NULL; |
---|
454 | return c; |
---|
455 | } |
---|
456 | |
---|
457 | |
---|
458 | char *lerror(char const *loc, char const *cause) |
---|
459 | { |
---|
460 | int lines; |
---|
461 | if (loc) |
---|
462 | { |
---|
463 | for (lines=0;*loc && lines<10;loc++) |
---|
464 | { |
---|
465 | if (*loc=='\n') lines++; |
---|
466 | dprintf("%c", *loc); |
---|
467 | } |
---|
468 | dprintf("\nPROGRAM LOCATION : \n"); |
---|
469 | } |
---|
470 | if (cause) |
---|
471 | dprintf("ERROR MESSAGE : %s\n", cause); |
---|
472 | lbreak(""); |
---|
473 | exit(0); |
---|
474 | return NULL; |
---|
475 | } |
---|
476 | |
---|
477 | void *nth(int num, void *list) |
---|
478 | { |
---|
479 | if (num<0) |
---|
480 | { |
---|
481 | lbreak("NTH: %d is not a nonnegative fixnum and therefore not a valid index\n", num); |
---|
482 | exit(1); |
---|
483 | } |
---|
484 | |
---|
485 | while (list && num) |
---|
486 | { |
---|
487 | list=CDR(list); |
---|
488 | num--; |
---|
489 | } |
---|
490 | if (!list) return NULL; |
---|
491 | else return CAR(list); |
---|
492 | } |
---|
493 | |
---|
494 | void *lpointer_value(void *lpointer) |
---|
495 | { |
---|
496 | if (!lpointer) return NULL; |
---|
497 | #ifdef TYPE_CHECKING |
---|
498 | else if (item_type(lpointer)!=L_POINTER) |
---|
499 | { |
---|
500 | lprint(lpointer); |
---|
501 | lbreak(" is not a pointer\n"); |
---|
502 | exit(0); |
---|
503 | } |
---|
504 | #endif |
---|
505 | return ((LispPointer *)lpointer)->addr; |
---|
506 | } |
---|
507 | |
---|
508 | int32_t lnumber_value(void *lnumber) |
---|
509 | { |
---|
510 | switch (item_type(lnumber)) |
---|
511 | { |
---|
512 | case L_NUMBER : |
---|
513 | return ((LispNumber *)lnumber)->num; |
---|
514 | case L_FIXED_POINT : |
---|
515 | return (((LispFixedPoint *)lnumber)->x)>>16; |
---|
516 | case L_STRING : |
---|
517 | return (uint8_t)*lstring_value(lnumber); |
---|
518 | case L_CHARACTER : |
---|
519 | return lcharacter_value(lnumber); |
---|
520 | default : |
---|
521 | { |
---|
522 | lprint(lnumber); |
---|
523 | lbreak(" is not a number\n"); |
---|
524 | exit(0); |
---|
525 | } |
---|
526 | } |
---|
527 | return 0; |
---|
528 | } |
---|
529 | |
---|
530 | char *lstring_value(void *lstring) |
---|
531 | { |
---|
532 | #ifdef TYPE_CHECKING |
---|
533 | if (item_type(lstring)!=(ltype)L_STRING) |
---|
534 | { |
---|
535 | lprint(lstring); |
---|
536 | lbreak(" is not a string\n"); |
---|
537 | exit(0); |
---|
538 | } |
---|
539 | #endif |
---|
540 | return ((char *)lstring)+sizeof(LispString); |
---|
541 | } |
---|
542 | |
---|
543 | |
---|
544 | |
---|
545 | void *lisp_atom(void *i) |
---|
546 | { |
---|
547 | if (item_type(i)==(ltype)L_CONS_CELL) |
---|
548 | return NULL; |
---|
549 | else return true_symbol; |
---|
550 | } |
---|
551 | |
---|
552 | void *lcdr(void *c) |
---|
553 | { |
---|
554 | if (!c) return NULL; |
---|
555 | else if (item_type(c)==(ltype)L_CONS_CELL) |
---|
556 | return ((LispList *)c)->cdr; |
---|
557 | else |
---|
558 | return NULL; |
---|
559 | } |
---|
560 | |
---|
561 | void *lcar(void *c) |
---|
562 | { |
---|
563 | if (!c) return NULL; |
---|
564 | else if (item_type(c)==(ltype)L_CONS_CELL) |
---|
565 | return ((LispList *)c)->car; |
---|
566 | else return NULL; |
---|
567 | } |
---|
568 | |
---|
569 | uint16_t lcharacter_value(void *c) |
---|
570 | { |
---|
571 | #ifdef TYPE_CHECKING |
---|
572 | if (item_type(c)!=L_CHARACTER) |
---|
573 | { |
---|
574 | lprint(c); |
---|
575 | lbreak("is not a character\n"); |
---|
576 | exit(0); |
---|
577 | } |
---|
578 | #endif |
---|
579 | return ((LispChar *)c)->ch; |
---|
580 | } |
---|
581 | |
---|
582 | long lfixed_point_value(void *c) |
---|
583 | { |
---|
584 | switch (item_type(c)) |
---|
585 | { |
---|
586 | case L_NUMBER : |
---|
587 | return ((LispNumber *)c)->num<<16; break; |
---|
588 | case L_FIXED_POINT : |
---|
589 | return (((LispFixedPoint *)c)->x); break; |
---|
590 | default : |
---|
591 | { |
---|
592 | lprint(c); |
---|
593 | lbreak(" is not a number\n"); |
---|
594 | exit(0); |
---|
595 | } |
---|
596 | } |
---|
597 | return 0; |
---|
598 | } |
---|
599 | |
---|
600 | void *lisp_eq(void *n1, void *n2) |
---|
601 | { |
---|
602 | if (!n1 && !n2) return true_symbol; |
---|
603 | else if ((n1 && !n2) || (n2 && !n1)) return NULL; |
---|
604 | { |
---|
605 | int t1=*((ltype *)n1), t2=*((ltype *)n2); |
---|
606 | if (t1!=t2) return NULL; |
---|
607 | else if (t1==L_NUMBER) |
---|
608 | { if (((LispNumber *)n1)->num==((LispNumber *)n2)->num) |
---|
609 | return true_symbol; |
---|
610 | else return NULL; |
---|
611 | } else if (t1==L_CHARACTER) |
---|
612 | { |
---|
613 | if (((LispChar *)n1)->ch==((LispChar *)n2)->ch) |
---|
614 | return true_symbol; |
---|
615 | else return NULL; |
---|
616 | } |
---|
617 | else if (n1==n2) |
---|
618 | return true_symbol; |
---|
619 | else if (t1==L_POINTER) |
---|
620 | if (n1==n2) return true_symbol; |
---|
621 | } |
---|
622 | return NULL; |
---|
623 | } |
---|
624 | |
---|
625 | void *lget_array_element(void *a, long x) |
---|
626 | { |
---|
627 | #ifdef TYPE_CHECKING |
---|
628 | if (item_type(a)!=L_1D_ARRAY) |
---|
629 | { |
---|
630 | lprint(a); |
---|
631 | lbreak("is not an array\n"); |
---|
632 | exit(0); |
---|
633 | } |
---|
634 | #endif |
---|
635 | if (x>=((LispArray *)a)->size || x<0) |
---|
636 | { |
---|
637 | lbreak("array refrence out of bounds (%d)\n", x); |
---|
638 | exit(0); |
---|
639 | } |
---|
640 | return ((void **)(((LispArray *)a)+1))[x]; |
---|
641 | } |
---|
642 | |
---|
643 | void *lisp_equal(void *n1, void *n2) |
---|
644 | { |
---|
645 | if(!n1 && !n2) // if both nil, then equal |
---|
646 | return true_symbol; |
---|
647 | |
---|
648 | if(!n1 || !n2) // one nil, nope |
---|
649 | return NULL; |
---|
650 | |
---|
651 | int t1 = item_type(n1), t2 = item_type(n2); |
---|
652 | if(t1 != t2) |
---|
653 | return NULL; |
---|
654 | |
---|
655 | switch (t1) |
---|
656 | { |
---|
657 | case L_STRING : |
---|
658 | if (!strcmp(lstring_value(n1), lstring_value(n2))) |
---|
659 | return true_symbol; |
---|
660 | return NULL; |
---|
661 | case L_CONS_CELL : |
---|
662 | while (n1 && n2) // loop through the list and compare each element |
---|
663 | { |
---|
664 | if (!lisp_equal(CAR(n1), CAR(n2))) |
---|
665 | return NULL; |
---|
666 | n1=CDR(n1); |
---|
667 | n2=CDR(n2); |
---|
668 | if (n1 && *((ltype *)n1)!=L_CONS_CELL) |
---|
669 | return lisp_equal(n1, n2); |
---|
670 | } |
---|
671 | if (n1 || n2) |
---|
672 | return NULL; // if one is longer than the other |
---|
673 | return true_symbol; |
---|
674 | default : |
---|
675 | return lisp_eq(n1, n2); |
---|
676 | } |
---|
677 | } |
---|
678 | |
---|
679 | int32_t lisp_cos(int32_t x) |
---|
680 | { |
---|
681 | x=(x+FIXED_TRIG_SIZE/4)%FIXED_TRIG_SIZE; |
---|
682 | if (x<0) return sin_table[FIXED_TRIG_SIZE+x]; |
---|
683 | else return sin_table[x]; |
---|
684 | } |
---|
685 | |
---|
686 | int32_t lisp_sin(int32_t x) |
---|
687 | { |
---|
688 | x=x%FIXED_TRIG_SIZE; |
---|
689 | if (x<0) return sin_table[FIXED_TRIG_SIZE+x]; |
---|
690 | else return sin_table[x]; |
---|
691 | } |
---|
692 | |
---|
693 | int32_t lisp_atan2(int32_t dy, int32_t dx) |
---|
694 | { |
---|
695 | if (dy==0) |
---|
696 | { |
---|
697 | if (dx>0) return 0; |
---|
698 | else return 180; |
---|
699 | } else if (dx==0) |
---|
700 | { |
---|
701 | if (dy>0) return 90; |
---|
702 | else return 270; |
---|
703 | } else |
---|
704 | { |
---|
705 | if (dx>0) |
---|
706 | { |
---|
707 | if (dy>0) |
---|
708 | { |
---|
709 | if (abs(dx)>abs(dy)) |
---|
710 | { |
---|
711 | int32_t a=dx*29/dy; |
---|
712 | if (a>=TBS) return 0; |
---|
713 | else return 45-atan_table[a]; |
---|
714 | } |
---|
715 | else |
---|
716 | { |
---|
717 | int32_t a=dy*29/dx; |
---|
718 | if (a>=TBS) return 90; |
---|
719 | else return 45+atan_table[a]; |
---|
720 | } |
---|
721 | } else |
---|
722 | { |
---|
723 | if (abs(dx)>abs(dy)) |
---|
724 | { |
---|
725 | int32_t a=dx*29/abs(dy); |
---|
726 | if (a>=TBS) |
---|
727 | return 0; |
---|
728 | else |
---|
729 | return 315+atan_table[a]; |
---|
730 | } |
---|
731 | else |
---|
732 | { |
---|
733 | int32_t a=abs(dy)*29/dx; |
---|
734 | if (a>=TBS) |
---|
735 | return 260; |
---|
736 | else |
---|
737 | return 315-atan_table[a]; |
---|
738 | } |
---|
739 | } |
---|
740 | } else |
---|
741 | { |
---|
742 | if (dy>0) |
---|
743 | { |
---|
744 | if (abs(dx)>abs(dy)) |
---|
745 | { |
---|
746 | int32_t a=-dx*29/dy; |
---|
747 | if (a>=TBS) |
---|
748 | return 135+45; |
---|
749 | else |
---|
750 | return 135+atan_table[a]; |
---|
751 | } |
---|
752 | else |
---|
753 | { |
---|
754 | int32_t a=dy*29/-dx; |
---|
755 | if (a>=TBS) |
---|
756 | return 135-45; |
---|
757 | else |
---|
758 | return 135-atan_table[a]; |
---|
759 | } |
---|
760 | } else |
---|
761 | { |
---|
762 | if (abs(dx)>abs(dy)) |
---|
763 | { |
---|
764 | int32_t a=-dx*29/abs(dy); |
---|
765 | if (a>=TBS) |
---|
766 | return 225-45; |
---|
767 | else return 225-atan_table[a]; |
---|
768 | } |
---|
769 | else |
---|
770 | { |
---|
771 | int32_t a=abs(dy)*29/abs(dx); |
---|
772 | if (a>=TBS) |
---|
773 | return 225+45; |
---|
774 | else return 225+atan_table[a]; |
---|
775 | } |
---|
776 | } |
---|
777 | } |
---|
778 | } |
---|
779 | } |
---|
780 | |
---|
781 | |
---|
782 | /* |
---|
783 | LispSymbol *find_symbol(char const *name) |
---|
784 | { |
---|
785 | LispList *cs; |
---|
786 | for (cs=(LispList *)symbol_list;cs;cs=(LispList *)CDR(cs)) |
---|
787 | { |
---|
788 | if (!strcmp( ((char *)((LispSymbol *)cs->car)->name)+sizeof(LispString), name)) |
---|
789 | return (LispSymbol *)(cs->car); |
---|
790 | } |
---|
791 | return NULL; |
---|
792 | } |
---|
793 | |
---|
794 | |
---|
795 | LispSymbol *make_find_symbol(char const *name) // find a symbol, if it doesn't exsist it is created |
---|
796 | { |
---|
797 | LispSymbol *s=find_symbol(name); |
---|
798 | if (s) return s; |
---|
799 | else |
---|
800 | { |
---|
801 | int sp=current_space; |
---|
802 | if (current_space!=GC_SPACE) |
---|
803 | current_space=PERM_SPACE; // make sure all symbols get defined in permanant space |
---|
804 | LispList *cs; |
---|
805 | cs=new_cons_cell(); |
---|
806 | s=new_lisp_symbol(name); |
---|
807 | cs->car=s; |
---|
808 | cs->cdr=symbol_list; |
---|
809 | symbol_list=cs; |
---|
810 | current_space=sp; |
---|
811 | } |
---|
812 | return s; |
---|
813 | } |
---|
814 | |
---|
815 | */ |
---|
816 | |
---|
817 | LispSymbol *find_symbol(char const *name) |
---|
818 | { |
---|
819 | LispSymbol *p=lsym_root; |
---|
820 | while (p) |
---|
821 | { |
---|
822 | int cmp=strcmp(name, ((char *)p->name)+sizeof(LispString)); |
---|
823 | if (cmp==0) return p; |
---|
824 | else if (cmp<0) p=p->left; |
---|
825 | else p=p->right; |
---|
826 | } |
---|
827 | return NULL; |
---|
828 | } |
---|
829 | |
---|
830 | |
---|
831 | |
---|
832 | LispSymbol *make_find_symbol(char const *name) |
---|
833 | { |
---|
834 | LispSymbol *p=lsym_root; |
---|
835 | LispSymbol **parent=&lsym_root; |
---|
836 | while (p) |
---|
837 | { |
---|
838 | int cmp=strcmp(name, ((char *)p->name)+sizeof(LispString)); |
---|
839 | if (cmp==0) return p; |
---|
840 | else if (cmp<0) |
---|
841 | { |
---|
842 | parent=&p->left; |
---|
843 | p=p->left; |
---|
844 | } |
---|
845 | else |
---|
846 | { |
---|
847 | parent=&p->right; |
---|
848 | p=p->right; |
---|
849 | } |
---|
850 | } |
---|
851 | int sp=current_space; |
---|
852 | if (current_space!=GC_SPACE) |
---|
853 | current_space=PERM_SPACE; // make sure all symbols get defined in permanant space |
---|
854 | |
---|
855 | p=(LispSymbol *)malloc(sizeof(LispSymbol)); |
---|
856 | p->type=L_SYMBOL; |
---|
857 | p->name=new_lisp_string(name); |
---|
858 | |
---|
859 | if (name[0]==':') // constant, set the value to ourself |
---|
860 | p->value=p; |
---|
861 | else |
---|
862 | p->value=l_undefined; |
---|
863 | p->function=l_undefined; |
---|
864 | #ifdef L_PROFILE |
---|
865 | p->time_taken=0; |
---|
866 | #endif |
---|
867 | p->left=p->right=NULL; |
---|
868 | *parent=p; |
---|
869 | ltotal_syms++; |
---|
870 | |
---|
871 | current_space=sp; |
---|
872 | return p; |
---|
873 | } |
---|
874 | |
---|
875 | |
---|
876 | void ldelete_syms(LispSymbol *root) |
---|
877 | { |
---|
878 | if (root) |
---|
879 | { |
---|
880 | ldelete_syms(root->left); |
---|
881 | ldelete_syms(root->right); |
---|
882 | free(root); |
---|
883 | } |
---|
884 | } |
---|
885 | |
---|
886 | void *assoc(void *item, void *list) |
---|
887 | { |
---|
888 | if (item_type(list)!=(ltype)L_CONS_CELL) |
---|
889 | return NULL; |
---|
890 | else |
---|
891 | { |
---|
892 | while (list) |
---|
893 | { |
---|
894 | if (lisp_eq(CAR(CAR(list)), item)) |
---|
895 | return lcar(list); |
---|
896 | list=(LispList *)(CDR(list)); |
---|
897 | } |
---|
898 | } |
---|
899 | return NULL; |
---|
900 | } |
---|
901 | |
---|
902 | long list_length(void *i) |
---|
903 | { |
---|
904 | long x; |
---|
905 | |
---|
906 | #ifdef TYPE_CHECKING |
---|
907 | if (i && item_type(i)!=(ltype)L_CONS_CELL) |
---|
908 | { |
---|
909 | lprint(i); |
---|
910 | lbreak(" is not a sequence\n"); |
---|
911 | exit(0); |
---|
912 | } |
---|
913 | #endif |
---|
914 | |
---|
915 | for(x = 0; i; i = CDR(i)) |
---|
916 | x++; |
---|
917 | return x; |
---|
918 | } |
---|
919 | |
---|
920 | |
---|
921 | |
---|
922 | void *pairlis(void *list1, void *list2, void *list3) |
---|
923 | { |
---|
924 | if (item_type(list1)!=(ltype)L_CONS_CELL || item_type(list1)!=item_type(list2)) |
---|
925 | return NULL; |
---|
926 | |
---|
927 | void *ret=NULL; |
---|
928 | long l1=list_length(list1), l2=list_length(list2); |
---|
929 | if (l1!=l2) |
---|
930 | { |
---|
931 | lprint(list1); |
---|
932 | lprint(list2); |
---|
933 | lbreak("... are not the same length (pairlis)\n"); |
---|
934 | exit(0); |
---|
935 | } |
---|
936 | if (l1!=0) |
---|
937 | { |
---|
938 | void *first=NULL, *last=NULL, *cur=NULL, *tmp; |
---|
939 | p_ref r1(first), r2(last), r3(cur); |
---|
940 | while (list1) |
---|
941 | { |
---|
942 | cur=new_cons_cell(); |
---|
943 | if (!first) first=cur; |
---|
944 | if (last) |
---|
945 | ((LispList *)last)->cdr=cur; |
---|
946 | last=cur; |
---|
947 | |
---|
948 | LispList *cell=new_cons_cell(); |
---|
949 | tmp=lcar(list1); |
---|
950 | ((LispList *)cell)->car=tmp; |
---|
951 | tmp=lcar(list2); |
---|
952 | ((LispList *)cell)->cdr=tmp; |
---|
953 | ((LispList *)cur)->car=cell; |
---|
954 | |
---|
955 | list1=((LispList *)list1)->cdr; |
---|
956 | list2=((LispList *)list2)->cdr; |
---|
957 | } |
---|
958 | ((LispList *)cur)->cdr=list3; |
---|
959 | ret=first; |
---|
960 | } else ret=NULL; |
---|
961 | return ret; |
---|
962 | } |
---|
963 | |
---|
964 | void *lookup_symbol_function(void *symbol) |
---|
965 | { |
---|
966 | return ((LispSymbol *)symbol)->function; |
---|
967 | } |
---|
968 | |
---|
969 | void set_symbol_function(void *symbol, void *function) |
---|
970 | { |
---|
971 | ((LispSymbol *)symbol)->function=function; |
---|
972 | } |
---|
973 | |
---|
974 | void *lookup_symbol_value(void *symbol) |
---|
975 | { |
---|
976 | #ifdef TYPE_CHECKING |
---|
977 | if (((LispSymbol *)symbol)->value!=l_undefined) |
---|
978 | #endif |
---|
979 | return ((LispSymbol *)symbol)->value; |
---|
980 | #ifdef TYPE_CHECKING |
---|
981 | else |
---|
982 | { |
---|
983 | lprint(symbol); |
---|
984 | lbreak(" has no value\n"); |
---|
985 | exit(0); |
---|
986 | } |
---|
987 | #endif |
---|
988 | return NULL; |
---|
989 | } |
---|
990 | |
---|
991 | void set_variable_value(void *symbol, void *value) |
---|
992 | { |
---|
993 | ((LispSymbol *) symbol)->value=value; |
---|
994 | } |
---|
995 | |
---|
996 | LispSymbol *add_sys_function(char const *name, short min_args, short max_args, short number) |
---|
997 | { |
---|
998 | need_perm_space("add_sys_function"); |
---|
999 | LispSymbol *s=make_find_symbol(name); |
---|
1000 | if (s->function!=l_undefined) |
---|
1001 | { |
---|
1002 | lbreak("add_sys_fucntion -> symbol %s already has a function\n", name); |
---|
1003 | exit(0); |
---|
1004 | } |
---|
1005 | else s->function=new_lisp_sys_function(min_args, max_args, number); |
---|
1006 | return s; |
---|
1007 | } |
---|
1008 | |
---|
1009 | LispSymbol *add_c_object(void *symbol, int16_t number) |
---|
1010 | { |
---|
1011 | need_perm_space("add_c_object"); |
---|
1012 | LispSymbol *s=(LispSymbol *)symbol; |
---|
1013 | if (s->value!=l_undefined) |
---|
1014 | { |
---|
1015 | lbreak("add_c_object -> symbol %s already has a value\n", lstring_value(symbol_name(s))); |
---|
1016 | exit(0); |
---|
1017 | } |
---|
1018 | else s->value=new_lisp_object_var(number); |
---|
1019 | return NULL; |
---|
1020 | } |
---|
1021 | |
---|
1022 | LispSymbol *add_c_function(char const *name, short min_args, short max_args, short number) |
---|
1023 | { |
---|
1024 | total_user_functions++; |
---|
1025 | need_perm_space("add_c_function"); |
---|
1026 | LispSymbol *s=make_find_symbol(name); |
---|
1027 | if (s->function!=l_undefined) |
---|
1028 | { |
---|
1029 | lbreak("add_sys_fucntion -> symbol %s already has a function\n", name); |
---|
1030 | exit(0); |
---|
1031 | } |
---|
1032 | else s->function=new_lisp_c_function(min_args, max_args, number); |
---|
1033 | return s; |
---|
1034 | } |
---|
1035 | |
---|
1036 | LispSymbol *add_c_bool_fun(char const *name, short min_args, short max_args, short number) |
---|
1037 | { |
---|
1038 | total_user_functions++; |
---|
1039 | need_perm_space("add_c_bool_fun"); |
---|
1040 | LispSymbol *s=make_find_symbol(name); |
---|
1041 | if (s->function!=l_undefined) |
---|
1042 | { |
---|
1043 | lbreak("add_sys_fucntion -> symbol %s already has a function\n", name); |
---|
1044 | exit(0); |
---|
1045 | } |
---|
1046 | else s->function=new_lisp_c_bool(min_args, max_args, number); |
---|
1047 | return s; |
---|
1048 | } |
---|
1049 | |
---|
1050 | |
---|
1051 | LispSymbol *add_lisp_function(char const *name, short min_args, short max_args, short number) |
---|
1052 | { |
---|
1053 | total_user_functions++; |
---|
1054 | need_perm_space("add_c_bool_fun"); |
---|
1055 | LispSymbol *s=make_find_symbol(name); |
---|
1056 | if (s->function!=l_undefined) |
---|
1057 | { |
---|
1058 | lbreak("add_sys_fucntion -> symbol %s already has a function\n", name); |
---|
1059 | exit(0); |
---|
1060 | } |
---|
1061 | else s->function=new_user_lisp_function(min_args, max_args, number); |
---|
1062 | return s; |
---|
1063 | } |
---|
1064 | |
---|
1065 | void skip_c_comment(char const *&s) |
---|
1066 | { |
---|
1067 | s+=2; |
---|
1068 | while (*s && (*s!='*' || *(s+1)!='/')) |
---|
1069 | { |
---|
1070 | if (*s=='/' && *(s+1)=='*') |
---|
1071 | skip_c_comment(s); |
---|
1072 | else s++; |
---|
1073 | } |
---|
1074 | if (*s) s+=2; |
---|
1075 | } |
---|
1076 | |
---|
1077 | long str_token_len(char const *st) |
---|
1078 | { |
---|
1079 | long x=1; |
---|
1080 | while (*st && (*st!='"' || st[1]=='"')) |
---|
1081 | { |
---|
1082 | if (*st=='\\' || *st=='"') st++; |
---|
1083 | st++; x++; |
---|
1084 | } |
---|
1085 | return x; |
---|
1086 | } |
---|
1087 | |
---|
1088 | int read_ltoken(char const *&s, char *buffer) |
---|
1089 | { |
---|
1090 | // skip space |
---|
1091 | while (*s==' ' || *s=='\t' || *s=='\n' || *s=='\r' || *s==26) s++; |
---|
1092 | if (*s==';') // comment |
---|
1093 | { |
---|
1094 | while (*s && *s!='\n' && *s!='\r' && *s!=26) s++; |
---|
1095 | return read_ltoken(s, buffer); |
---|
1096 | } else if (*s=='/' && *(s+1)=='*') // c style comment |
---|
1097 | { |
---|
1098 | skip_c_comment(s); |
---|
1099 | return read_ltoken(s, buffer); |
---|
1100 | } |
---|
1101 | else if (*s==0) |
---|
1102 | return 0; |
---|
1103 | else if (*s==')' || *s=='(' || *s=='\'' || *s=='`' || *s==',' || *s==26) |
---|
1104 | { |
---|
1105 | *(buffer++)=*(s++); |
---|
1106 | *buffer=0; |
---|
1107 | } else if (*s=='"') // string |
---|
1108 | { |
---|
1109 | *(buffer++)=*(s++); // don't read off the string because it |
---|
1110 | // may be to long to fit in the token buffer |
---|
1111 | // so just read the '"' so the compiler knows to scan the rest. |
---|
1112 | *buffer=0; |
---|
1113 | } else if (*s=='#') |
---|
1114 | { |
---|
1115 | *(buffer++)=*(s++); |
---|
1116 | if (*s!='\'') |
---|
1117 | *(buffer++)=*(s++); |
---|
1118 | *buffer=0; |
---|
1119 | } else |
---|
1120 | { |
---|
1121 | while (*s && *s!=')' && *s!='(' && *s!=' ' && *s!='\n' && *s!='\r' && *s!='\t' && *s!=';' && *s!=26) |
---|
1122 | *(buffer++)=*(s++); |
---|
1123 | *buffer=0; |
---|
1124 | } |
---|
1125 | return 1; |
---|
1126 | } |
---|
1127 | |
---|
1128 | |
---|
1129 | char n[MAX_LISP_TOKEN_LEN]; // assume all tokens will be < 200 characters |
---|
1130 | |
---|
1131 | int end_of_program(char const *s) |
---|
1132 | { |
---|
1133 | return !read_ltoken(s, n); |
---|
1134 | } |
---|
1135 | |
---|
1136 | |
---|
1137 | void push_onto_list(void *object, void *&list) |
---|
1138 | { |
---|
1139 | p_ref r1(object), r2(list); |
---|
1140 | LispList *c=new_cons_cell(); |
---|
1141 | c->car=object; |
---|
1142 | c->cdr=list; |
---|
1143 | list=c; |
---|
1144 | } |
---|
1145 | |
---|
1146 | void *comp_optimize(void *list); |
---|
1147 | |
---|
1148 | void *compile(char const *&s) |
---|
1149 | { |
---|
1150 | void *ret=NULL; |
---|
1151 | if (!read_ltoken(s, n)) |
---|
1152 | lerror(NULL, "unexpected end of program"); |
---|
1153 | if (!strcmp(n, "nil")) |
---|
1154 | return NULL; |
---|
1155 | else if (toupper(n[0])=='T' && !n[1]) |
---|
1156 | return true_symbol; |
---|
1157 | else if (n[0]=='\'') // short hand for quote function |
---|
1158 | { |
---|
1159 | void *cs=new_cons_cell(), *c2=NULL, *tmp; |
---|
1160 | p_ref r1(cs), r2(c2); |
---|
1161 | |
---|
1162 | ((LispList *)cs)->car=quote_symbol; |
---|
1163 | c2=new_cons_cell(); |
---|
1164 | tmp=compile(s); |
---|
1165 | ((LispList *)c2)->car=tmp; |
---|
1166 | ((LispList *)c2)->cdr=NULL; |
---|
1167 | ((LispList *)cs)->cdr=c2; |
---|
1168 | ret=cs; |
---|
1169 | } |
---|
1170 | else if (n[0]=='`') // short hand for backquote function |
---|
1171 | { |
---|
1172 | void *cs=new_cons_cell(), *c2=NULL, *tmp; |
---|
1173 | p_ref r1(cs), r2(c2); |
---|
1174 | |
---|
1175 | ((LispList *)cs)->car=backquote_symbol; |
---|
1176 | c2=new_cons_cell(); |
---|
1177 | tmp=compile(s); |
---|
1178 | ((LispList *)c2)->car=tmp; |
---|
1179 | ((LispList *)c2)->cdr=NULL; |
---|
1180 | ((LispList *)cs)->cdr=c2; |
---|
1181 | ret=cs; |
---|
1182 | } else if (n[0]==',') // short hand for comma function |
---|
1183 | { |
---|
1184 | void *cs=new_cons_cell(), *c2=NULL, *tmp; |
---|
1185 | p_ref r1(cs), r2(c2); |
---|
1186 | |
---|
1187 | ((LispList *)cs)->car=comma_symbol; |
---|
1188 | c2=new_cons_cell(); |
---|
1189 | tmp=compile(s); |
---|
1190 | ((LispList *)c2)->car=tmp; |
---|
1191 | ((LispList *)c2)->cdr=NULL; |
---|
1192 | ((LispList *)cs)->cdr=c2; |
---|
1193 | ret=cs; |
---|
1194 | } |
---|
1195 | else if (n[0]=='(') // make a list of everything in () |
---|
1196 | { |
---|
1197 | void *first=NULL, *cur=NULL, *last=NULL; |
---|
1198 | p_ref r1(first), r2(cur), r3(last); |
---|
1199 | int done=0; |
---|
1200 | do |
---|
1201 | { |
---|
1202 | char const *tmp=s; |
---|
1203 | if (!read_ltoken(tmp, n)) // check for the end of the list |
---|
1204 | lerror(NULL, "unexpected end of program"); |
---|
1205 | if (n[0]==')') |
---|
1206 | { |
---|
1207 | done=1; |
---|
1208 | read_ltoken(s, n); // read off the ')' |
---|
1209 | } |
---|
1210 | else |
---|
1211 | { |
---|
1212 | if (n[0]=='.' && !n[1]) |
---|
1213 | { |
---|
1214 | if (!first) |
---|
1215 | lerror(s, "token '.' not allowed here\n"); |
---|
1216 | else |
---|
1217 | { |
---|
1218 | void *tmp; |
---|
1219 | read_ltoken(s, n); // skip the '.' |
---|
1220 | tmp=compile(s); |
---|
1221 | ((LispList *)last)->cdr=tmp; // link the last cdr to |
---|
1222 | last=NULL; |
---|
1223 | } |
---|
1224 | } else if (!last && first) |
---|
1225 | lerror(s, "illegal end of dotted list\n"); |
---|
1226 | else |
---|
1227 | { |
---|
1228 | void *tmp; |
---|
1229 | cur=new_cons_cell(); |
---|
1230 | p_ref r1(cur); |
---|
1231 | if (!first) first=cur; |
---|
1232 | tmp=compile(s); |
---|
1233 | ((LispList *)cur)->car=tmp; |
---|
1234 | if (last) |
---|
1235 | ((LispList *)last)->cdr=cur; |
---|
1236 | last=cur; |
---|
1237 | } |
---|
1238 | } |
---|
1239 | } while (!done); |
---|
1240 | ret=comp_optimize(first); |
---|
1241 | |
---|
1242 | } else if (n[0]==')') |
---|
1243 | lerror(s, "mismatched )"); |
---|
1244 | else if (isdigit(n[0]) || (n[0]=='-' && isdigit(n[1]))) |
---|
1245 | { |
---|
1246 | LispNumber *num=new_lisp_number(0); |
---|
1247 | sscanf(n, "%ld", &num->num); |
---|
1248 | ret=num; |
---|
1249 | } else if (n[0]=='"') |
---|
1250 | { |
---|
1251 | ret=new_lisp_string(str_token_len(s)); |
---|
1252 | char *start=lstring_value(ret); |
---|
1253 | for (;*s && (*s!='"' || s[1]=='"');s++, start++) |
---|
1254 | { |
---|
1255 | if (*s=='\\') |
---|
1256 | { |
---|
1257 | s++; |
---|
1258 | if (*s=='n') *start='\n'; |
---|
1259 | if (*s=='r') *start='\r'; |
---|
1260 | if (*s=='t') *start='\t'; |
---|
1261 | if (*s=='\\') *start='\\'; |
---|
1262 | } else *start=*s; |
---|
1263 | if (*s=='"') s++; |
---|
1264 | } |
---|
1265 | *start=0; |
---|
1266 | s++; |
---|
1267 | } else if (n[0]=='#') |
---|
1268 | { |
---|
1269 | if (n[1]=='\\') |
---|
1270 | { |
---|
1271 | read_ltoken(s, n); // read character name |
---|
1272 | if (!strcmp(n, "newline")) |
---|
1273 | ret=new_lisp_character('\n'); |
---|
1274 | else if (!strcmp(n, "space")) |
---|
1275 | ret=new_lisp_character(' '); |
---|
1276 | else |
---|
1277 | ret=new_lisp_character(n[0]); |
---|
1278 | } |
---|
1279 | else if (n[1]==0) // short hand for function |
---|
1280 | { |
---|
1281 | void *cs=new_cons_cell(), *c2=NULL, *tmp; |
---|
1282 | p_ref r4(cs), r5(c2); |
---|
1283 | tmp=make_find_symbol("function"); |
---|
1284 | ((LispList *)cs)->car=tmp; |
---|
1285 | c2=new_cons_cell(); |
---|
1286 | tmp=compile(s); |
---|
1287 | ((LispList *)c2)->car=tmp; |
---|
1288 | ((LispList *)cs)->cdr=c2; |
---|
1289 | ret=cs; |
---|
1290 | } |
---|
1291 | else |
---|
1292 | { |
---|
1293 | lbreak("Unknown #\\ notation : %s\n", n); |
---|
1294 | exit(0); |
---|
1295 | } |
---|
1296 | } else { |
---|
1297 | ret = make_find_symbol(n); |
---|
1298 | } |
---|
1299 | return ret; |
---|
1300 | } |
---|
1301 | |
---|
1302 | |
---|
1303 | static void lprint_string(char const *st) |
---|
1304 | { |
---|
1305 | if (current_print_file) |
---|
1306 | { |
---|
1307 | for (char const *s=st;*s;s++) |
---|
1308 | { |
---|
1309 | /* if (*s=='\\') |
---|
1310 | { |
---|
1311 | s++; |
---|
1312 | if (*s=='n') |
---|
1313 | current_print_file->write_uint8('\n'); |
---|
1314 | else if (*s=='r') |
---|
1315 | current_print_file->write_uint8('\r'); |
---|
1316 | else if (*s=='t') |
---|
1317 | current_print_file->write_uint8('\t'); |
---|
1318 | else if (*s=='\\') |
---|
1319 | current_print_file->write_uint8('\\'); |
---|
1320 | } |
---|
1321 | else*/ |
---|
1322 | current_print_file->write_uint8(*s); |
---|
1323 | } |
---|
1324 | } |
---|
1325 | else |
---|
1326 | dprintf(st); |
---|
1327 | } |
---|
1328 | |
---|
1329 | void lprint(void *i) |
---|
1330 | { |
---|
1331 | print_level++; |
---|
1332 | if (!i) |
---|
1333 | lprint_string("nil"); |
---|
1334 | else |
---|
1335 | { |
---|
1336 | switch ((short)item_type(i)) |
---|
1337 | { |
---|
1338 | case L_CONS_CELL : |
---|
1339 | { |
---|
1340 | LispList *cs=(LispList *)i; |
---|
1341 | lprint_string("("); |
---|
1342 | for (;cs;cs=(LispList *)lcdr(cs)) |
---|
1343 | { |
---|
1344 | if (item_type(cs)==(ltype)L_CONS_CELL) |
---|
1345 | { |
---|
1346 | lprint(cs->car); |
---|
1347 | if (cs->cdr) |
---|
1348 | lprint_string(" "); |
---|
1349 | } |
---|
1350 | else |
---|
1351 | { |
---|
1352 | lprint_string(". "); |
---|
1353 | lprint(cs); |
---|
1354 | cs=NULL; |
---|
1355 | } |
---|
1356 | } |
---|
1357 | lprint_string(")"); |
---|
1358 | } |
---|
1359 | break; |
---|
1360 | case L_NUMBER : |
---|
1361 | { |
---|
1362 | char num[10]; |
---|
1363 | sprintf(num, "%ld", ((LispNumber *)i)->num); |
---|
1364 | lprint_string(num); |
---|
1365 | } |
---|
1366 | break; |
---|
1367 | case L_SYMBOL : |
---|
1368 | lprint_string((char *)(((LispSymbol *)i)->name)+sizeof(LispString)); |
---|
1369 | break; |
---|
1370 | case L_USER_FUNCTION : |
---|
1371 | case L_SYS_FUNCTION : |
---|
1372 | lprint_string("err... function?"); |
---|
1373 | break; |
---|
1374 | case L_C_FUNCTION : |
---|
1375 | lprint_string("C function, returns number\n"); |
---|
1376 | break; |
---|
1377 | case L_C_BOOL : |
---|
1378 | lprint_string("C boolean function\n"); |
---|
1379 | break; |
---|
1380 | case L_L_FUNCTION : |
---|
1381 | lprint_string("External lisp function\n"); |
---|
1382 | break; |
---|
1383 | case L_STRING : |
---|
1384 | { |
---|
1385 | if (current_print_file) |
---|
1386 | lprint_string(lstring_value(i)); |
---|
1387 | else |
---|
1388 | dprintf("\"%s\"", lstring_value(i)); |
---|
1389 | } |
---|
1390 | break; |
---|
1391 | |
---|
1392 | case L_POINTER : |
---|
1393 | { |
---|
1394 | char ptr[10]; |
---|
1395 | sprintf(ptr, "%p", lpointer_value(i)); |
---|
1396 | lprint_string(ptr); |
---|
1397 | } |
---|
1398 | break; |
---|
1399 | case L_FIXED_POINT : |
---|
1400 | { |
---|
1401 | char num[20]; |
---|
1402 | sprintf(num, "%g", (lfixed_point_value(i)>>16)+ |
---|
1403 | ((lfixed_point_value(i)&0xffff))/(double)0x10000); |
---|
1404 | lprint_string(num); |
---|
1405 | } break; |
---|
1406 | case L_CHARACTER : |
---|
1407 | { |
---|
1408 | if (current_print_file) |
---|
1409 | { |
---|
1410 | uint8_t ch=((LispChar *)i)->ch; |
---|
1411 | current_print_file->write(&ch, 1); |
---|
1412 | } else |
---|
1413 | { |
---|
1414 | uint16_t ch=((LispChar *)i)->ch; |
---|
1415 | dprintf("#\\"); |
---|
1416 | switch (ch) |
---|
1417 | { |
---|
1418 | case '\n' : |
---|
1419 | { dprintf("newline"); break; } |
---|
1420 | case ' ' : |
---|
1421 | { dprintf("space"); break; } |
---|
1422 | default : |
---|
1423 | dprintf("%c", ch); |
---|
1424 | } |
---|
1425 | } |
---|
1426 | } break; |
---|
1427 | case L_OBJECT_VAR : |
---|
1428 | { |
---|
1429 | l_obj_print(((LispObjectVar *)i)->number); |
---|
1430 | } break; |
---|
1431 | case L_1D_ARRAY : |
---|
1432 | { |
---|
1433 | LispArray *a=(LispArray *)i; |
---|
1434 | void **data=(void **)(a+1); |
---|
1435 | dprintf("#("); |
---|
1436 | for (int j=0;j<a->size;j++) |
---|
1437 | { |
---|
1438 | lprint(data[j]); |
---|
1439 | if (j!=a->size-1) |
---|
1440 | dprintf(" "); |
---|
1441 | } |
---|
1442 | dprintf(")"); |
---|
1443 | } break; |
---|
1444 | case L_COLLECTED_OBJECT : |
---|
1445 | { |
---|
1446 | lprint_string("GC_refrence->"); |
---|
1447 | lprint(((LispRedirect *)i)->new_reference); |
---|
1448 | } break; |
---|
1449 | default : |
---|
1450 | dprintf("Shouldn't happen\n"); |
---|
1451 | } |
---|
1452 | } |
---|
1453 | print_level--; |
---|
1454 | if (!print_level && !current_print_file) |
---|
1455 | dprintf("\n"); |
---|
1456 | } |
---|
1457 | |
---|
1458 | void *eval_sys_function(LispSysFunction *fun, void *arg_list); |
---|
1459 | |
---|
1460 | void *eval_function(LispSymbol *sym, void *arg_list) |
---|
1461 | { |
---|
1462 | #ifdef TYPE_CHECKING |
---|
1463 | int args, req_min, req_max; |
---|
1464 | if (item_type(sym)!=L_SYMBOL) |
---|
1465 | { |
---|
1466 | lprint(sym); |
---|
1467 | lbreak("EVAL : is not a function name (not symbol either)"); |
---|
1468 | exit(0); |
---|
1469 | } |
---|
1470 | #endif |
---|
1471 | |
---|
1472 | void *fun=(LispSysFunction *)(((LispSymbol *)sym)->function); |
---|
1473 | p_ref ref2( fun ); |
---|
1474 | |
---|
1475 | // make sure the arguments given to the function are the correct number |
---|
1476 | ltype t=item_type(fun); |
---|
1477 | |
---|
1478 | #ifdef TYPE_CHECKING |
---|
1479 | switch (t) |
---|
1480 | { |
---|
1481 | case L_SYS_FUNCTION : |
---|
1482 | case L_C_FUNCTION : |
---|
1483 | case L_C_BOOL : |
---|
1484 | case L_L_FUNCTION : |
---|
1485 | { |
---|
1486 | req_min=((LispSysFunction *)fun)->min_args; |
---|
1487 | req_max=((LispSysFunction *)fun)->max_args; |
---|
1488 | } break; |
---|
1489 | case L_USER_FUNCTION : |
---|
1490 | { |
---|
1491 | return eval_user_fun(sym, arg_list); |
---|
1492 | } break; |
---|
1493 | default : |
---|
1494 | { |
---|
1495 | lprint(sym); |
---|
1496 | lbreak(" is not a function name"); |
---|
1497 | exit(0); |
---|
1498 | } break; |
---|
1499 | } |
---|
1500 | |
---|
1501 | if (req_min!=-1) |
---|
1502 | { |
---|
1503 | void *a=arg_list; |
---|
1504 | for (args=0;a;a=CDR(a)) args++; // count number of paramaters |
---|
1505 | |
---|
1506 | if (args<req_min) |
---|
1507 | { |
---|
1508 | lprint(arg_list); |
---|
1509 | lprint(sym->name); |
---|
1510 | lbreak("\nToo few parameters to function\n"); |
---|
1511 | exit(0); |
---|
1512 | } else if (req_max!=-1 && args>req_max) |
---|
1513 | { |
---|
1514 | lprint(arg_list); |
---|
1515 | lprint(sym->name); |
---|
1516 | lbreak("\nToo many parameters to function\n"); |
---|
1517 | exit(0); |
---|
1518 | } |
---|
1519 | } |
---|
1520 | #endif |
---|
1521 | |
---|
1522 | #ifdef L_PROFILE |
---|
1523 | time_marker start; |
---|
1524 | #endif |
---|
1525 | |
---|
1526 | |
---|
1527 | p_ref ref1(arg_list); |
---|
1528 | void *ret=NULL; |
---|
1529 | |
---|
1530 | switch (t) |
---|
1531 | { |
---|
1532 | case L_SYS_FUNCTION : |
---|
1533 | { ret=eval_sys_function( ((LispSysFunction *)fun), arg_list); } break; |
---|
1534 | case L_L_FUNCTION : |
---|
1535 | { ret=l_caller( ((LispSysFunction *)fun)->fun_number, arg_list); } break; |
---|
1536 | case L_USER_FUNCTION : |
---|
1537 | { |
---|
1538 | return eval_user_fun(sym, arg_list); |
---|
1539 | } break; |
---|
1540 | case L_C_FUNCTION : |
---|
1541 | case L_C_BOOL : |
---|
1542 | { |
---|
1543 | void *first=NULL, *cur=NULL, *tmp; |
---|
1544 | p_ref r1(first), r2(cur); |
---|
1545 | while (arg_list) |
---|
1546 | { |
---|
1547 | if (first) { |
---|
1548 | tmp=new_cons_cell(); |
---|
1549 | ((LispList *)cur)->cdr=tmp; |
---|
1550 | cur=tmp; |
---|
1551 | } else |
---|
1552 | cur=first=new_cons_cell(); |
---|
1553 | |
---|
1554 | void *val=eval(CAR(arg_list)); |
---|
1555 | ((LispList *)cur)->car=val; |
---|
1556 | arg_list=lcdr(arg_list); |
---|
1557 | } |
---|
1558 | if(t == L_C_FUNCTION) |
---|
1559 | ret=new_lisp_number(c_caller( ((LispSysFunction *)fun)->fun_number, first)); |
---|
1560 | else if (c_caller( ((LispSysFunction *)fun)->fun_number, first)) |
---|
1561 | ret=true_symbol; |
---|
1562 | else ret=NULL; |
---|
1563 | } break; |
---|
1564 | default : |
---|
1565 | fprintf(stderr, "not a fun, shouldn't happen\n"); |
---|
1566 | } |
---|
1567 | |
---|
1568 | #ifdef L_PROFILE |
---|
1569 | time_marker end; |
---|
1570 | ((LispSymbol *)sym)->time_taken+=end.diff_time(&start); |
---|
1571 | #endif |
---|
1572 | |
---|
1573 | return ret; |
---|
1574 | } |
---|
1575 | |
---|
1576 | #ifdef L_PROFILE |
---|
1577 | void pro_print(bFILE *out, LispSymbol *p) |
---|
1578 | { |
---|
1579 | if (p) |
---|
1580 | { |
---|
1581 | pro_print(out, p->right); |
---|
1582 | { |
---|
1583 | char st[100]; |
---|
1584 | sprintf(st, "%20s %f\n", lstring_value(symbol_name(p)), ((LispSymbol *)p)->time_taken); |
---|
1585 | out->write(st, strlen(st)); |
---|
1586 | } |
---|
1587 | pro_print(out, p->left); |
---|
1588 | } |
---|
1589 | } |
---|
1590 | |
---|
1591 | void preport(char *fn) |
---|
1592 | { |
---|
1593 | bFILE *fp=open_file("preport.out", "wb"); |
---|
1594 | pro_print(fp, lsym_root); |
---|
1595 | delete fp; |
---|
1596 | } |
---|
1597 | #endif |
---|
1598 | |
---|
1599 | void *mapcar(void *arg_list) |
---|
1600 | { |
---|
1601 | p_ref ref1(arg_list); |
---|
1602 | void *sym=eval(CAR(arg_list)); |
---|
1603 | switch ((short)item_type(sym)) |
---|
1604 | { |
---|
1605 | case L_SYS_FUNCTION : |
---|
1606 | case L_USER_FUNCTION : |
---|
1607 | case L_SYMBOL : |
---|
1608 | break; |
---|
1609 | default : |
---|
1610 | { |
---|
1611 | lprint(sym); |
---|
1612 | lbreak(" is not a function\n"); |
---|
1613 | exit(0); |
---|
1614 | } |
---|
1615 | } |
---|
1616 | int num_args=list_length(CDR(arg_list)), i, stop=0; |
---|
1617 | if (!num_args) return 0; |
---|
1618 | |
---|
1619 | void **arg_on=(void **)malloc(sizeof(void *)*num_args); |
---|
1620 | LispList *list_on=(LispList *)CDR(arg_list); |
---|
1621 | long old_ptr_son=l_ptr_stack.son; |
---|
1622 | |
---|
1623 | for (i=0;i<num_args;i++) |
---|
1624 | { |
---|
1625 | arg_on[i]=(LispList *)eval(CAR(list_on)); |
---|
1626 | l_ptr_stack.push(&arg_on[i]); |
---|
1627 | |
---|
1628 | list_on=(LispList *)CDR(list_on); |
---|
1629 | if (!arg_on[i]) stop=1; |
---|
1630 | } |
---|
1631 | |
---|
1632 | if (stop) |
---|
1633 | { |
---|
1634 | free(arg_on); |
---|
1635 | return NULL; |
---|
1636 | } |
---|
1637 | |
---|
1638 | LispList *na_list=NULL, *return_list=NULL, *last_return=NULL; |
---|
1639 | |
---|
1640 | do |
---|
1641 | { |
---|
1642 | na_list=NULL; // create a cons list with all of the parameters for the function |
---|
1643 | |
---|
1644 | LispList *first=NULL; // save the start of the list |
---|
1645 | for (i=0;!stop &&i<num_args;i++) |
---|
1646 | { |
---|
1647 | if (!na_list) |
---|
1648 | first=na_list=new_cons_cell(); |
---|
1649 | else |
---|
1650 | { |
---|
1651 | na_list->cdr=new_cons_cell(); |
---|
1652 | na_list=(LispList *)CDR(na_list); |
---|
1653 | } |
---|
1654 | |
---|
1655 | |
---|
1656 | if (arg_on[i]) |
---|
1657 | { |
---|
1658 | na_list->car=CAR(arg_on[i]); |
---|
1659 | arg_on[i]=(LispList *)CDR(arg_on[i]); |
---|
1660 | } |
---|
1661 | else stop=1; |
---|
1662 | } |
---|
1663 | if (!stop) |
---|
1664 | { |
---|
1665 | LispList *c=new_cons_cell(); |
---|
1666 | c->car=eval_function((LispSymbol *)sym, first); |
---|
1667 | if (return_list) |
---|
1668 | last_return->cdr=c; |
---|
1669 | else |
---|
1670 | return_list=c; |
---|
1671 | last_return=c; |
---|
1672 | } |
---|
1673 | } |
---|
1674 | while (!stop); |
---|
1675 | l_ptr_stack.son=old_ptr_son; |
---|
1676 | |
---|
1677 | free(arg_on); |
---|
1678 | return return_list; |
---|
1679 | } |
---|
1680 | |
---|
1681 | void *concatenate(void *prog_list) |
---|
1682 | { |
---|
1683 | void *el_list=CDR(prog_list); |
---|
1684 | p_ref ref1(prog_list), ref2(el_list); |
---|
1685 | void *ret=NULL; |
---|
1686 | void *rtype=eval(CAR(prog_list)); |
---|
1687 | |
---|
1688 | long len=0; // determin the length of the resulting string |
---|
1689 | if (rtype==string_symbol) |
---|
1690 | { |
---|
1691 | int elements=list_length(el_list); // see how many things we need to concat |
---|
1692 | if (!elements) ret=new_lisp_string(""); |
---|
1693 | else |
---|
1694 | { |
---|
1695 | void **str_eval=(void **)malloc(elements*sizeof(void *)); |
---|
1696 | int i, old_ptr_stack_start=l_ptr_stack.son; |
---|
1697 | |
---|
1698 | // evalaute all the strings and count their lengths |
---|
1699 | for (i=0;i<elements;i++, el_list=CDR(el_list)) |
---|
1700 | { |
---|
1701 | str_eval[i]=eval(CAR(el_list)); |
---|
1702 | l_ptr_stack.push(&str_eval[i]); |
---|
1703 | |
---|
1704 | switch ((short)item_type(str_eval[i])) |
---|
1705 | { |
---|
1706 | case L_CONS_CELL : |
---|
1707 | { |
---|
1708 | LispList *char_list=(LispList *)str_eval[i]; |
---|
1709 | while (char_list) |
---|
1710 | { |
---|
1711 | if (item_type(CAR(char_list))==(ltype)L_CHARACTER) |
---|
1712 | len++; |
---|
1713 | else |
---|
1714 | { |
---|
1715 | lprint(str_eval[i]); |
---|
1716 | lbreak(" is not a character\n"); |
---|
1717 | exit(0); |
---|
1718 | } |
---|
1719 | char_list=(LispList *)CDR(char_list); |
---|
1720 | } |
---|
1721 | } break; |
---|
1722 | case L_STRING : len+=strlen(lstring_value(str_eval[i])); break; |
---|
1723 | default : |
---|
1724 | lprint(prog_list); |
---|
1725 | lbreak("type not supported\n"); |
---|
1726 | exit(0); |
---|
1727 | break; |
---|
1728 | |
---|
1729 | } |
---|
1730 | } |
---|
1731 | LispString *st=new_lisp_string(len+1); |
---|
1732 | char *s=lstring_value(st); |
---|
1733 | |
---|
1734 | // now add the string up into the new string |
---|
1735 | for (i=0;i<elements;i++) |
---|
1736 | { |
---|
1737 | switch ((short)item_type(str_eval[i])) |
---|
1738 | { |
---|
1739 | case L_CONS_CELL : |
---|
1740 | { |
---|
1741 | LispList *char_list=(LispList *)str_eval[i]; |
---|
1742 | while (char_list) |
---|
1743 | { |
---|
1744 | if (item_type(CAR(char_list))==L_CHARACTER) |
---|
1745 | *(s++)=((LispChar *)CAR(char_list))->ch; |
---|
1746 | char_list=(LispList *)CDR(char_list); |
---|
1747 | } |
---|
1748 | } break; |
---|
1749 | case L_STRING : |
---|
1750 | { |
---|
1751 | memcpy(s, lstring_value(str_eval[i]), strlen(lstring_value(str_eval[i]))); |
---|
1752 | s+=strlen(lstring_value(str_eval[i])); |
---|
1753 | } break; |
---|
1754 | default : ; // already checked for, but make compiler happy |
---|
1755 | } |
---|
1756 | } |
---|
1757 | free(str_eval); |
---|
1758 | l_ptr_stack.son=old_ptr_stack_start; // restore pointer GC stack |
---|
1759 | *s=0; |
---|
1760 | ret=st; |
---|
1761 | } |
---|
1762 | } |
---|
1763 | else |
---|
1764 | { |
---|
1765 | lprint(prog_list); |
---|
1766 | lbreak("concat operation not supported, try 'string\n"); |
---|
1767 | exit(0); |
---|
1768 | } |
---|
1769 | return ret; |
---|
1770 | } |
---|
1771 | |
---|
1772 | |
---|
1773 | void *backquote_eval(void *args) |
---|
1774 | { |
---|
1775 | if (item_type(args)!=L_CONS_CELL) |
---|
1776 | return args; |
---|
1777 | else if (args==NULL) |
---|
1778 | return NULL; |
---|
1779 | else if ((LispSymbol *) (((LispList *)args)->car)==comma_symbol) |
---|
1780 | return eval(CAR(CDR(args))); |
---|
1781 | else |
---|
1782 | { |
---|
1783 | void *first=NULL, *last=NULL, *cur=NULL, *tmp; |
---|
1784 | p_ref ref1(first), ref2(last), ref3(cur), ref4(args); |
---|
1785 | while (args) |
---|
1786 | { |
---|
1787 | if (item_type(args)==L_CONS_CELL) |
---|
1788 | { |
---|
1789 | if (CAR(args)==comma_symbol) // dot list with a comma? |
---|
1790 | { |
---|
1791 | tmp=eval(CAR(CDR(args))); |
---|
1792 | ((LispList *)last)->cdr=tmp; |
---|
1793 | args=NULL; |
---|
1794 | } |
---|
1795 | else |
---|
1796 | { |
---|
1797 | cur=new_cons_cell(); |
---|
1798 | if (first) |
---|
1799 | ((LispList *)last)->cdr=cur; |
---|
1800 | else |
---|
1801 | first=cur; |
---|
1802 | last=cur; |
---|
1803 | tmp=backquote_eval(CAR(args)); |
---|
1804 | ((LispList *)cur)->car=tmp; |
---|
1805 | args=CDR(args); |
---|
1806 | } |
---|
1807 | } else |
---|
1808 | { |
---|
1809 | tmp=backquote_eval(args); |
---|
1810 | ((LispList *)last)->cdr=tmp; |
---|
1811 | args=NULL; |
---|
1812 | } |
---|
1813 | |
---|
1814 | } |
---|
1815 | return (void *)first; |
---|
1816 | } |
---|
1817 | return NULL; // for stupid compiler messages |
---|
1818 | } |
---|
1819 | |
---|
1820 | |
---|
1821 | void *eval_sys_function(LispSysFunction *fun, void *arg_list) |
---|
1822 | { |
---|
1823 | p_ref ref1(arg_list); |
---|
1824 | void *ret=NULL; |
---|
1825 | switch (fun->fun_number) |
---|
1826 | { |
---|
1827 | case SYS_FUNC_PRINT: |
---|
1828 | { |
---|
1829 | ret=NULL; |
---|
1830 | while (arg_list) |
---|
1831 | { |
---|
1832 | ret=eval(CAR(arg_list)); arg_list=CDR(arg_list); |
---|
1833 | lprint(ret); |
---|
1834 | } |
---|
1835 | return ret; |
---|
1836 | } break; |
---|
1837 | case SYS_FUNC_CAR: |
---|
1838 | { ret=lcar(eval(CAR(arg_list))); } break; |
---|
1839 | case SYS_FUNC_CDR: |
---|
1840 | { ret=lcdr(eval(CAR(arg_list))); } break; |
---|
1841 | case SYS_FUNC_LENGTH: |
---|
1842 | { |
---|
1843 | void *v=eval(CAR(arg_list)); |
---|
1844 | switch (item_type(v)) |
---|
1845 | { |
---|
1846 | case L_STRING : ret=new_lisp_number(strlen(lstring_value(v))); break; |
---|
1847 | case L_CONS_CELL : ret=new_lisp_number(list_length(v)); break; |
---|
1848 | default : |
---|
1849 | { lprint(v); |
---|
1850 | lbreak("length : type not supported\n"); |
---|
1851 | } |
---|
1852 | } |
---|
1853 | } break; |
---|
1854 | case SYS_FUNC_LIST: |
---|
1855 | { |
---|
1856 | void *cur=NULL, *last=NULL, *first=NULL; |
---|
1857 | p_ref r1(cur), r2(first), r3(last); |
---|
1858 | while (arg_list) |
---|
1859 | { |
---|
1860 | cur=new_cons_cell(); |
---|
1861 | void *val=eval(CAR(arg_list)); |
---|
1862 | ((LispList *) cur)->car=val; |
---|
1863 | if (last) |
---|
1864 | ((LispList *)last)->cdr=cur; |
---|
1865 | else first=cur; |
---|
1866 | last=cur; |
---|
1867 | arg_list=(LispList *)CDR(arg_list); |
---|
1868 | } |
---|
1869 | ret=first; |
---|
1870 | } break; |
---|
1871 | case SYS_FUNC_CONS: |
---|
1872 | { void *c=new_cons_cell(); |
---|
1873 | p_ref r1(c); |
---|
1874 | void *val=eval(CAR(arg_list)); |
---|
1875 | ((LispList *)c)->car=val; |
---|
1876 | val=eval(CAR(CDR(arg_list))); |
---|
1877 | ((LispList *)c)->cdr=val; |
---|
1878 | ret=c; |
---|
1879 | } break; |
---|
1880 | case SYS_FUNC_QUOTE: |
---|
1881 | ret=CAR(arg_list); |
---|
1882 | break; |
---|
1883 | case SYS_FUNC_EQ: |
---|
1884 | { |
---|
1885 | l_user_stack.push(eval(CAR(arg_list))); |
---|
1886 | l_user_stack.push(eval(CAR(CDR(arg_list)))); |
---|
1887 | ret=lisp_eq(l_user_stack.pop(1), l_user_stack.pop(1)); |
---|
1888 | } break; |
---|
1889 | case SYS_FUNC_EQUAL: |
---|
1890 | { |
---|
1891 | l_user_stack.push(eval(CAR(arg_list))); |
---|
1892 | l_user_stack.push(eval(CAR(CDR(arg_list)))); |
---|
1893 | ret=lisp_equal(l_user_stack.pop(1), l_user_stack.pop(1)); |
---|
1894 | } break; |
---|
1895 | case SYS_FUNC_PLUS: |
---|
1896 | { |
---|
1897 | long sum=0; |
---|
1898 | while (arg_list) |
---|
1899 | { |
---|
1900 | sum+=lnumber_value(eval(CAR(arg_list))); |
---|
1901 | arg_list=CDR(arg_list); |
---|
1902 | } |
---|
1903 | ret=new_lisp_number(sum); |
---|
1904 | } |
---|
1905 | break; |
---|
1906 | case SYS_FUNC_TIMES: |
---|
1907 | { |
---|
1908 | long sum; |
---|
1909 | void *first=eval(CAR(arg_list)); |
---|
1910 | p_ref r1(first); |
---|
1911 | if (arg_list && item_type(first)==L_FIXED_POINT) |
---|
1912 | { |
---|
1913 | sum=1<<16; |
---|
1914 | do |
---|
1915 | { |
---|
1916 | sum=(sum>>8)*(lfixed_point_value(first)>>8); |
---|
1917 | arg_list=CDR(arg_list); |
---|
1918 | if (arg_list) first=eval(CAR(arg_list)); |
---|
1919 | } while (arg_list); |
---|
1920 | |
---|
1921 | ret=new_lisp_fixed_point(sum); |
---|
1922 | } else |
---|
1923 | { sum=1; |
---|
1924 | do |
---|
1925 | { |
---|
1926 | sum*=lnumber_value(eval(CAR(arg_list))); |
---|
1927 | arg_list=CDR(arg_list); |
---|
1928 | if (arg_list) first=eval(CAR(arg_list)); |
---|
1929 | } while (arg_list); |
---|
1930 | ret=new_lisp_number(sum); |
---|
1931 | } |
---|
1932 | } |
---|
1933 | break; |
---|
1934 | case SYS_FUNC_SLASH: |
---|
1935 | { |
---|
1936 | long sum=0, first=1; |
---|
1937 | while (arg_list) |
---|
1938 | { |
---|
1939 | void *i=eval(CAR(arg_list)); |
---|
1940 | p_ref r1(i); |
---|
1941 | if (item_type(i)!=L_NUMBER) |
---|
1942 | { |
---|
1943 | lprint(i); |
---|
1944 | lbreak("/ only defined for numbers, cannot divide "); |
---|
1945 | exit(0); |
---|
1946 | } else if (first) |
---|
1947 | { |
---|
1948 | sum=((LispNumber *)i)->num; |
---|
1949 | first=0; |
---|
1950 | } |
---|
1951 | else sum/=((LispNumber *)i)->num; |
---|
1952 | arg_list=CDR(arg_list); |
---|
1953 | } |
---|
1954 | ret=new_lisp_number(sum); |
---|
1955 | } |
---|
1956 | break; |
---|
1957 | case SYS_FUNC_MINUS: |
---|
1958 | { |
---|
1959 | long x=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
1960 | while (arg_list) |
---|
1961 | { |
---|
1962 | x-=lnumber_value(eval(CAR(arg_list))); |
---|
1963 | arg_list=CDR(arg_list); |
---|
1964 | } |
---|
1965 | ret=new_lisp_number(x); |
---|
1966 | } |
---|
1967 | break; |
---|
1968 | case SYS_FUNC_IF: |
---|
1969 | { |
---|
1970 | if (eval(CAR(arg_list))) |
---|
1971 | ret=eval(CAR(CDR(arg_list))); |
---|
1972 | else |
---|
1973 | { arg_list=CDR(CDR(arg_list)); // check for a else part |
---|
1974 | if (arg_list) |
---|
1975 | ret=eval(CAR(arg_list)); |
---|
1976 | else ret=NULL; |
---|
1977 | } |
---|
1978 | } break; |
---|
1979 | case SYS_FUNC_SETQ: |
---|
1980 | case SYS_FUNC_SETF: |
---|
1981 | { |
---|
1982 | void *set_to=eval(CAR(CDR(arg_list))), *i=NULL; |
---|
1983 | p_ref r1(set_to), r2(i); |
---|
1984 | i=CAR(arg_list); |
---|
1985 | |
---|
1986 | ltype x=item_type(set_to); |
---|
1987 | switch (item_type(i)) |
---|
1988 | { |
---|
1989 | case L_SYMBOL : |
---|
1990 | { |
---|
1991 | switch (item_type (((LispSymbol *)i)->value)) |
---|
1992 | { |
---|
1993 | case L_NUMBER : |
---|
1994 | { |
---|
1995 | if (x==L_NUMBER && ((LispSymbol *)i)->value!=l_undefined) |
---|
1996 | ((LispNumber *)(((LispSymbol *)i)->value))->num=lnumber_value(set_to); |
---|
1997 | else |
---|
1998 | ((LispSymbol *)i)->value=set_to; |
---|
1999 | } break; |
---|
2000 | case L_OBJECT_VAR : |
---|
2001 | { |
---|
2002 | l_obj_set(((LispObjectVar *)(((LispSymbol *)i)->value))->number, set_to); |
---|
2003 | } break; |
---|
2004 | default : |
---|
2005 | ((LispSymbol *)i)->value=set_to; |
---|
2006 | } |
---|
2007 | ret=((LispSymbol *)i)->value; |
---|
2008 | } break; |
---|
2009 | case L_CONS_CELL : // this better be an 'aref' |
---|
2010 | { |
---|
2011 | #ifdef TYPE_CHECKING |
---|
2012 | void *car=((LispList *)i)->car; |
---|
2013 | if (car==car_symbol) |
---|
2014 | { |
---|
2015 | car=eval(CAR(CDR(i))); |
---|
2016 | if (!car || item_type(car)!=L_CONS_CELL) |
---|
2017 | { lprint(car); lbreak("setq car : evaled object is not a cons cell\n"); exit(0); } |
---|
2018 | ((LispList *)car)->car=set_to; |
---|
2019 | } else if (car==cdr_symbol) |
---|
2020 | { |
---|
2021 | car=eval(CAR(CDR(i))); |
---|
2022 | if (!car || item_type(car)!=L_CONS_CELL) |
---|
2023 | { lprint(car); lbreak("setq cdr : evaled object is not a cons cell\n"); exit(0); } |
---|
2024 | ((LispList *)car)->cdr=set_to; |
---|
2025 | } else if (car==aref_symbol) |
---|
2026 | { |
---|
2027 | #endif |
---|
2028 | void *a=(LispArray *)eval(CAR(CDR(i))); |
---|
2029 | p_ref r1(a); |
---|
2030 | #ifdef TYPE_CHECKING |
---|
2031 | if (item_type(a)!=L_1D_ARRAY) |
---|
2032 | { |
---|
2033 | lprint(a); |
---|
2034 | lbreak("is not an array (aref)\n"); |
---|
2035 | exit(0); |
---|
2036 | } |
---|
2037 | #endif |
---|
2038 | long num=lnumber_value(eval(CAR(CDR(CDR(i))))); |
---|
2039 | #ifdef TYPE_CHECKING |
---|
2040 | if (num>=((LispArray *)a)->size || num<0) |
---|
2041 | { |
---|
2042 | lbreak("aref : value of bounds (%d)\n", num); |
---|
2043 | exit(0); |
---|
2044 | } |
---|
2045 | #endif |
---|
2046 | void **data=(void **)(((LispArray *)a)+1); |
---|
2047 | data[num]=set_to; |
---|
2048 | #ifdef TYPE_CHECKING |
---|
2049 | } else |
---|
2050 | { |
---|
2051 | lbreak("expected (aref, car, cdr, or symbol) in setq\n"); |
---|
2052 | exit(0); |
---|
2053 | } |
---|
2054 | #endif |
---|
2055 | ret=set_to; |
---|
2056 | } break; |
---|
2057 | |
---|
2058 | default : |
---|
2059 | { |
---|
2060 | lprint(i); |
---|
2061 | lbreak("setq/setf only defined for symbols and arrays now..\n"); |
---|
2062 | exit(0); |
---|
2063 | } |
---|
2064 | } |
---|
2065 | } break; |
---|
2066 | case SYS_FUNC_SYMBOL_LIST: |
---|
2067 | ret=NULL; |
---|
2068 | break; |
---|
2069 | case SYS_FUNC_ASSOC: |
---|
2070 | { |
---|
2071 | void *item=eval(CAR(arg_list)); |
---|
2072 | p_ref r1(item); |
---|
2073 | void *list=(LispList *)eval(CAR(CDR(arg_list))); |
---|
2074 | p_ref r2(list); |
---|
2075 | ret=assoc(item, (LispList *)list); |
---|
2076 | } break; |
---|
2077 | case SYS_FUNC_NOT: |
---|
2078 | case SYS_FUNC_NULL: |
---|
2079 | if (eval(CAR(arg_list))==NULL) ret=true_symbol; else ret=NULL; |
---|
2080 | break; |
---|
2081 | case SYS_FUNC_ACONS: |
---|
2082 | { |
---|
2083 | void *i1=eval(CAR(arg_list)), *i2=eval(CAR(CDR(arg_list))); |
---|
2084 | p_ref r1(i1); |
---|
2085 | LispList *cs=new_cons_cell(); |
---|
2086 | cs->car=i1; |
---|
2087 | cs->cdr=i2; |
---|
2088 | ret=cs; |
---|
2089 | } break; |
---|
2090 | |
---|
2091 | case SYS_FUNC_PAIRLIS: |
---|
2092 | { |
---|
2093 | l_user_stack.push(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2094 | l_user_stack.push(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2095 | void *n3=eval(CAR(arg_list)); |
---|
2096 | void *n2=l_user_stack.pop(1); |
---|
2097 | void *n1=l_user_stack.pop(1); |
---|
2098 | ret=pairlis(n1, n2, n3); |
---|
2099 | } break; |
---|
2100 | case SYS_FUNC_LET: |
---|
2101 | { |
---|
2102 | // make an a-list of new variable names and new values |
---|
2103 | void *var_list=CAR(arg_list), |
---|
2104 | *block_list=CDR(arg_list); |
---|
2105 | p_ref r1(block_list), r2(var_list); |
---|
2106 | long stack_start=l_user_stack.son; |
---|
2107 | |
---|
2108 | while (var_list) |
---|
2109 | { |
---|
2110 | void *var_name=CAR(CAR(var_list)), *tmp; |
---|
2111 | #ifdef TYPE_CHECKING |
---|
2112 | if (item_type(var_name)!=L_SYMBOL) |
---|
2113 | { |
---|
2114 | lprint(var_name); |
---|
2115 | lbreak("should be a symbol (let)\n"); |
---|
2116 | exit(0); |
---|
2117 | } |
---|
2118 | #endif |
---|
2119 | |
---|
2120 | l_user_stack.push(((LispSymbol *)var_name)->value); |
---|
2121 | tmp=eval(CAR(CDR(CAR(var_list)))); |
---|
2122 | ((LispSymbol *)var_name)->value=tmp; |
---|
2123 | var_list=CDR(var_list); |
---|
2124 | } |
---|
2125 | |
---|
2126 | // now evaluate each of the blocks with the new enviroment and return value |
---|
2127 | // from the last block |
---|
2128 | while (block_list) |
---|
2129 | { |
---|
2130 | ret=eval(CAR(block_list)); |
---|
2131 | block_list=CDR(block_list); |
---|
2132 | } |
---|
2133 | |
---|
2134 | long cur_stack=stack_start; |
---|
2135 | var_list=CAR(arg_list); // now restore the old symbol values |
---|
2136 | while (var_list) |
---|
2137 | { |
---|
2138 | void *var_name=CAR(CAR(var_list)); |
---|
2139 | ((LispSymbol *)var_name)->value=l_user_stack.sdata[cur_stack++]; |
---|
2140 | var_list=CDR(var_list); |
---|
2141 | } |
---|
2142 | l_user_stack.son=stack_start; // restore the stack |
---|
2143 | } |
---|
2144 | break; |
---|
2145 | case SYS_FUNC_DEFUN: |
---|
2146 | { |
---|
2147 | void *symbol=CAR(arg_list); |
---|
2148 | #ifdef TYPE_CHECKING |
---|
2149 | if (item_type(symbol)!=L_SYMBOL) |
---|
2150 | { |
---|
2151 | lprint(symbol); |
---|
2152 | lbreak(" is not a symbol! (DEFUN)\n"); |
---|
2153 | exit(0); |
---|
2154 | } |
---|
2155 | |
---|
2156 | if (item_type(arg_list)!=L_CONS_CELL) |
---|
2157 | { |
---|
2158 | lprint(arg_list); |
---|
2159 | lbreak("is not a lambda list (DEFUN)\n"); |
---|
2160 | exit(0); |
---|
2161 | } |
---|
2162 | #endif |
---|
2163 | void *block_list=CDR(CDR(arg_list)); |
---|
2164 | |
---|
2165 | #ifndef NO_LIBS |
---|
2166 | intptr_t a=cache.reg_lisp_block(lcar(lcdr(arg_list))); |
---|
2167 | intptr_t b=cache.reg_lisp_block(block_list); |
---|
2168 | LispUserFunction *ufun=new_lisp_user_function(a, b); |
---|
2169 | #else |
---|
2170 | LispUserFunction *ufun=new_lisp_user_function(lcar(lcdr(arg_list)), block_list); |
---|
2171 | #endif |
---|
2172 | set_symbol_function(symbol, ufun); |
---|
2173 | ret=symbol; |
---|
2174 | } break; |
---|
2175 | case SYS_FUNC_ATOM: |
---|
2176 | { ret=lisp_atom(eval(CAR(arg_list))); } |
---|
2177 | case SYS_FUNC_AND: |
---|
2178 | { |
---|
2179 | void *l=arg_list; |
---|
2180 | p_ref r1(l); |
---|
2181 | ret=true_symbol; |
---|
2182 | while (l) |
---|
2183 | { |
---|
2184 | if (!eval(CAR(l))) |
---|
2185 | { |
---|
2186 | ret=NULL; |
---|
2187 | l=NULL; // short-circuit |
---|
2188 | } else l=CDR(l); |
---|
2189 | } |
---|
2190 | } break; |
---|
2191 | case SYS_FUNC_OR: |
---|
2192 | { |
---|
2193 | void *l=arg_list; |
---|
2194 | p_ref r1(l); |
---|
2195 | ret=NULL; |
---|
2196 | while (l) |
---|
2197 | { |
---|
2198 | if (eval(CAR(l))) |
---|
2199 | { |
---|
2200 | ret=true_symbol; |
---|
2201 | l=NULL; // short circuit |
---|
2202 | } else l=CDR(l); |
---|
2203 | } |
---|
2204 | } break; |
---|
2205 | case SYS_FUNC_PROGN: |
---|
2206 | { ret=eval_block(arg_list); } break; |
---|
2207 | case SYS_FUNC_CONCATENATE: |
---|
2208 | ret=concatenate(arg_list); |
---|
2209 | break; |
---|
2210 | case SYS_FUNC_CHAR_CODE: |
---|
2211 | { |
---|
2212 | void *i=eval(CAR(arg_list)); |
---|
2213 | p_ref r1(i); |
---|
2214 | ret=NULL; |
---|
2215 | switch (item_type(i)) |
---|
2216 | { |
---|
2217 | case L_CHARACTER : |
---|
2218 | { ret=new_lisp_number(((LispChar *)i)->ch); } break; |
---|
2219 | case L_STRING : |
---|
2220 | { ret=new_lisp_number(*lstring_value(i)); } break; |
---|
2221 | default : |
---|
2222 | { |
---|
2223 | lprint(i); |
---|
2224 | lbreak(" is not character type\n"); |
---|
2225 | exit(0); |
---|
2226 | } |
---|
2227 | } |
---|
2228 | } break; |
---|
2229 | case SYS_FUNC_CODE_CHAR: |
---|
2230 | { |
---|
2231 | void *i=eval(CAR(arg_list)); |
---|
2232 | p_ref r1(i); |
---|
2233 | if (item_type(i)!=L_NUMBER) |
---|
2234 | { |
---|
2235 | lprint(i); |
---|
2236 | lbreak(" is not number type\n"); |
---|
2237 | exit(0); |
---|
2238 | } |
---|
2239 | ret=new_lisp_character(((LispNumber *)i)->num); |
---|
2240 | } break; |
---|
2241 | case SYS_FUNC_COND: |
---|
2242 | { |
---|
2243 | void *block_list=CAR(arg_list); |
---|
2244 | p_ref r1(block_list); |
---|
2245 | if (!block_list) ret=NULL; |
---|
2246 | else |
---|
2247 | { |
---|
2248 | ret=NULL; |
---|
2249 | while (block_list) |
---|
2250 | { |
---|
2251 | if (eval(lcar(CAR(block_list)))) |
---|
2252 | ret=eval(CAR(CDR(CAR(block_list)))); |
---|
2253 | block_list=CDR(block_list); |
---|
2254 | } |
---|
2255 | } |
---|
2256 | } break; |
---|
2257 | case SYS_FUNC_SELECT: |
---|
2258 | { |
---|
2259 | void *selector=eval(CAR(arg_list)); |
---|
2260 | void *sel=CDR(arg_list); |
---|
2261 | p_ref r1(selector), r2(sel); |
---|
2262 | while (sel) |
---|
2263 | { |
---|
2264 | if (lisp_equal(selector, eval(CAR(CAR(sel))))) |
---|
2265 | { |
---|
2266 | sel=CDR(CAR(sel)); |
---|
2267 | while (sel) |
---|
2268 | { |
---|
2269 | ret=eval(CAR(sel)); |
---|
2270 | sel=CDR(sel); |
---|
2271 | } |
---|
2272 | sel=NULL; |
---|
2273 | } else sel=CDR(sel); |
---|
2274 | } |
---|
2275 | } break; |
---|
2276 | case SYS_FUNC_FUNCTION: |
---|
2277 | ret=lookup_symbol_function(eval(CAR(arg_list))); |
---|
2278 | break; |
---|
2279 | case SYS_FUNC_MAPCAR: |
---|
2280 | ret=mapcar(arg_list); |
---|
2281 | case SYS_FUNC_FUNCALL: |
---|
2282 | { |
---|
2283 | void *n1=eval(CAR(arg_list)); |
---|
2284 | ret=eval_function((LispSymbol *)n1, CDR(arg_list)); |
---|
2285 | } break; |
---|
2286 | case SYS_FUNC_GT: |
---|
2287 | { |
---|
2288 | long n1=lnumber_value(eval(CAR(arg_list))); |
---|
2289 | long n2=lnumber_value(eval(CAR(CDR(arg_list)))); |
---|
2290 | if (n1>n2) ret=true_symbol; else ret=NULL; |
---|
2291 | } |
---|
2292 | break; |
---|
2293 | case SYS_FUNC_LT: |
---|
2294 | { |
---|
2295 | long n1=lnumber_value(eval(CAR(arg_list))); |
---|
2296 | long n2=lnumber_value(eval(CAR(CDR(arg_list)))); |
---|
2297 | if (n1<n2) ret=true_symbol; else ret=NULL; |
---|
2298 | } |
---|
2299 | break; |
---|
2300 | case SYS_FUNC_GE: |
---|
2301 | { |
---|
2302 | long n1=lnumber_value(eval(CAR(arg_list))); |
---|
2303 | long n2=lnumber_value(eval(CAR(CDR(arg_list)))); |
---|
2304 | if (n1>=n2) ret=true_symbol; else ret=NULL; |
---|
2305 | } |
---|
2306 | break; |
---|
2307 | case SYS_FUNC_LE: |
---|
2308 | { |
---|
2309 | long n1=lnumber_value(eval(CAR(arg_list))); |
---|
2310 | long n2=lnumber_value(eval(CAR(CDR(arg_list)))); |
---|
2311 | if (n1<=n2) ret=true_symbol; else ret=NULL; |
---|
2312 | } |
---|
2313 | break; |
---|
2314 | |
---|
2315 | case SYS_FUNC_TMP_SPACE: |
---|
2316 | tmp_space(); |
---|
2317 | ret=true_symbol; |
---|
2318 | break; |
---|
2319 | case SYS_FUNC_PERM_SPACE: |
---|
2320 | perm_space(); |
---|
2321 | ret=true_symbol; |
---|
2322 | break; |
---|
2323 | case SYS_FUNC_SYMBOL_NAME: |
---|
2324 | void *symb; |
---|
2325 | symb=eval(CAR(arg_list)); |
---|
2326 | #ifdef TYPE_CHECKING |
---|
2327 | if (item_type(symb)!=L_SYMBOL) |
---|
2328 | { |
---|
2329 | lprint(symb); |
---|
2330 | lbreak(" is not a symbol (symbol-name)\n"); |
---|
2331 | exit(0); |
---|
2332 | } |
---|
2333 | #endif |
---|
2334 | ret=((LispSymbol *)symb)->name; |
---|
2335 | break; |
---|
2336 | case SYS_FUNC_TRACE: |
---|
2337 | trace_level++; |
---|
2338 | if (arg_list) |
---|
2339 | trace_print_level=lnumber_value(eval(CAR(arg_list))); |
---|
2340 | ret=true_symbol; |
---|
2341 | break; |
---|
2342 | case SYS_FUNC_UNTRACE: |
---|
2343 | if (trace_level>0) |
---|
2344 | { |
---|
2345 | trace_level--; |
---|
2346 | ret=true_symbol; |
---|
2347 | } else ret=NULL; |
---|
2348 | break; |
---|
2349 | case SYS_FUNC_DIGSTR: |
---|
2350 | { |
---|
2351 | char tmp[50], *tp; |
---|
2352 | long num=lnumber_value(eval(CAR(arg_list))); |
---|
2353 | long dig=lnumber_value(eval(CAR(CDR(arg_list)))); |
---|
2354 | tp=tmp+49; |
---|
2355 | *(tp--)=0; |
---|
2356 | for (;num;) |
---|
2357 | { |
---|
2358 | int d; |
---|
2359 | d=num%10; |
---|
2360 | *(tp--)=d+'0'; |
---|
2361 | num/=10; |
---|
2362 | dig--; |
---|
2363 | } |
---|
2364 | while (dig--) |
---|
2365 | *(tp--)='0'; |
---|
2366 | ret=new_lisp_string(tp+1); |
---|
2367 | } break; |
---|
2368 | case SYS_FUNC_LOCAL_LOAD: |
---|
2369 | case SYS_FUNC_LOAD: |
---|
2370 | case SYS_FUNC_COMPILE_FILE: |
---|
2371 | { |
---|
2372 | void *fn = eval( CAR( arg_list ) ); |
---|
2373 | char *st = lstring_value( fn ); |
---|
2374 | p_ref r1( fn ); |
---|
2375 | bFILE *fp; |
---|
2376 | if( fun->fun_number == SYS_FUNC_LOCAL_LOAD ) |
---|
2377 | { |
---|
2378 | // A special test for gamma.lsp |
---|
2379 | if( strcmp( st, "gamma.lsp" ) == 0 ) |
---|
2380 | { |
---|
2381 | char *gammapath; |
---|
2382 | gammapath = (char *)malloc( strlen( get_save_filename_prefix() ) + 9 + 1 ); |
---|
2383 | sprintf( gammapath, "%sgamma.lsp", get_save_filename_prefix() ); |
---|
2384 | fp = new jFILE( gammapath, "rb" ); |
---|
2385 | free( gammapath ); |
---|
2386 | } |
---|
2387 | else |
---|
2388 | { |
---|
2389 | fp = new jFILE( st, "rb" ); |
---|
2390 | } |
---|
2391 | } |
---|
2392 | else |
---|
2393 | { |
---|
2394 | fp = open_file(st, "rb"); |
---|
2395 | } |
---|
2396 | |
---|
2397 | if( fp->open_failure() ) |
---|
2398 | { |
---|
2399 | delete fp; |
---|
2400 | if( DEFINEDP(symbol_value(load_warning)) && symbol_value(load_warning) ) |
---|
2401 | dprintf("Warning : file %s does not exist\n", st); |
---|
2402 | ret = NULL; |
---|
2403 | } |
---|
2404 | else |
---|
2405 | { |
---|
2406 | long l=fp->file_size(); |
---|
2407 | char *s=(char *)malloc(l + 1); |
---|
2408 | if (!s) |
---|
2409 | { |
---|
2410 | printf("Malloc error in load_script\n"); |
---|
2411 | exit(0); |
---|
2412 | } |
---|
2413 | |
---|
2414 | fp->read(s, l); |
---|
2415 | s[l]=0; |
---|
2416 | delete fp; |
---|
2417 | char const *cs=s; |
---|
2418 | #ifndef NO_LIBS |
---|
2419 | char msg[100]; |
---|
2420 | sprintf(msg, "(load \"%s\")", st); |
---|
2421 | if (stat_man) stat_man->push(msg, NULL); |
---|
2422 | crc_manager.get_filenumber(st); // make sure this file gets crc'ed |
---|
2423 | #endif |
---|
2424 | void *compiled_form=NULL; |
---|
2425 | p_ref r11(compiled_form); |
---|
2426 | while (!end_of_program(cs)) // see if there is anything left to compile and run |
---|
2427 | { |
---|
2428 | #ifndef NO_LIBS |
---|
2429 | if (stat_man) stat_man->update((cs-s)*100/l); |
---|
2430 | #endif |
---|
2431 | void *m=mark_heap(TMP_SPACE); |
---|
2432 | compiled_form=compile(cs); |
---|
2433 | eval(compiled_form); |
---|
2434 | compiled_form=NULL; |
---|
2435 | restore_heap(m, TMP_SPACE); |
---|
2436 | } |
---|
2437 | #ifndef NO_LIBS |
---|
2438 | if (stat_man) stat_man->update(100); |
---|
2439 | if (stat_man) stat_man->pop(); |
---|
2440 | #endif |
---|
2441 | free(s); |
---|
2442 | ret=fn; |
---|
2443 | } |
---|
2444 | } break; |
---|
2445 | case SYS_FUNC_ABS: |
---|
2446 | ret=new_lisp_number(abs(lnumber_value(eval(CAR(arg_list))))); break; |
---|
2447 | case SYS_FUNC_MIN: |
---|
2448 | { |
---|
2449 | int x=lnumber_value(eval(CAR(arg_list))), y=lnumber_value(eval(CAR(CDR(arg_list)))); |
---|
2450 | if (x<y) ret=new_lisp_number(x); else ret=new_lisp_number(y); |
---|
2451 | } break; |
---|
2452 | case SYS_FUNC_MAX: |
---|
2453 | { |
---|
2454 | int x=lnumber_value(eval(CAR(arg_list))), y=lnumber_value(eval(CAR(CDR(arg_list)))); |
---|
2455 | if (x>y) ret=new_lisp_number(x); else ret=new_lisp_number(y); |
---|
2456 | } break; |
---|
2457 | case SYS_FUNC_BACKQUOTE: |
---|
2458 | { |
---|
2459 | ret=backquote_eval(CAR(arg_list)); |
---|
2460 | } break; |
---|
2461 | case SYS_FUNC_COMMA: |
---|
2462 | { |
---|
2463 | lprint(arg_list); |
---|
2464 | lbreak("comma is illegal outside of backquote\n"); |
---|
2465 | exit(0); |
---|
2466 | ret=NULL; |
---|
2467 | } break; |
---|
2468 | case SYS_FUNC_NTH: |
---|
2469 | { |
---|
2470 | long x=lnumber_value(eval(CAR(arg_list))); |
---|
2471 | ret=nth(x, eval(CAR(CDR(arg_list)))); |
---|
2472 | } break; |
---|
2473 | case SYS_FUNC_RESIZE_TMP: |
---|
2474 | resize_tmp(lnumber_value(eval(CAR(arg_list)))); break; |
---|
2475 | case SYS_FUNC_RESIZE_PERM: |
---|
2476 | resize_perm(lnumber_value(eval(CAR(arg_list)))); break; |
---|
2477 | case SYS_FUNC_COS: |
---|
2478 | ret=new_lisp_fixed_point(lisp_cos(lnumber_value(eval(CAR(arg_list))))); break; |
---|
2479 | case SYS_FUNC_SIN: |
---|
2480 | ret=new_lisp_fixed_point(lisp_sin(lnumber_value(eval(CAR(arg_list))))); break; |
---|
2481 | case SYS_FUNC_ATAN2: |
---|
2482 | { |
---|
2483 | long y=(lnumber_value(eval(CAR(arg_list)))); arg_list=CDR(arg_list); |
---|
2484 | long x=(lnumber_value(eval(CAR(arg_list)))); |
---|
2485 | ret=new_lisp_number(lisp_atan2(y, x)); |
---|
2486 | } break; |
---|
2487 | case SYS_FUNC_ENUM: |
---|
2488 | { |
---|
2489 | int sp=current_space; |
---|
2490 | current_space=PERM_SPACE; |
---|
2491 | long x=0; |
---|
2492 | while (arg_list) |
---|
2493 | { |
---|
2494 | void *sym=eval(CAR(arg_list)); |
---|
2495 | p_ref r1(sym); |
---|
2496 | switch (item_type(sym)) |
---|
2497 | { |
---|
2498 | case L_SYMBOL : |
---|
2499 | { ((LispSymbol *)sym)->value=new_lisp_number(x); } break; |
---|
2500 | case L_CONS_CELL : |
---|
2501 | { |
---|
2502 | void *s=eval(CAR(sym)); |
---|
2503 | p_ref r1(s); |
---|
2504 | #ifdef TYPE_CHECKING |
---|
2505 | if (item_type(s)!=L_SYMBOL) |
---|
2506 | { lprint(arg_list); |
---|
2507 | lbreak("expecting (sybmol value) for enum\n"); |
---|
2508 | exit(0); |
---|
2509 | } |
---|
2510 | #endif |
---|
2511 | x=lnumber_value(eval(CAR(CDR(sym)))); |
---|
2512 | ((LispSymbol *)sym)->value=new_lisp_number(x); |
---|
2513 | } break; |
---|
2514 | default : |
---|
2515 | { |
---|
2516 | lprint(arg_list); |
---|
2517 | lbreak("expecting symbol or (symbol value) in enum\n"); |
---|
2518 | exit(0); |
---|
2519 | } |
---|
2520 | } |
---|
2521 | arg_list=CDR(arg_list); |
---|
2522 | x++; |
---|
2523 | } |
---|
2524 | current_space=sp; |
---|
2525 | } break; |
---|
2526 | case SYS_FUNC_QUIT: |
---|
2527 | { |
---|
2528 | exit(0); |
---|
2529 | } break; |
---|
2530 | case SYS_FUNC_EVAL: |
---|
2531 | { |
---|
2532 | ret=eval(eval(CAR(arg_list))); |
---|
2533 | } break; |
---|
2534 | case SYS_FUNC_BREAK: lbreak("User break"); break; |
---|
2535 | case SYS_FUNC_MOD: |
---|
2536 | { |
---|
2537 | long x=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2538 | long y=lnumber_value(eval(CAR(arg_list))); |
---|
2539 | if (y==0) { lbreak("mod : division by zero\n"); y=1; } |
---|
2540 | ret=new_lisp_number(x%y); |
---|
2541 | } break; |
---|
2542 | /* case SYS_FUNC_WRITE_PROFILE: |
---|
2543 | { |
---|
2544 | char *fn=lstring_value(eval(CAR(arg_list))); |
---|
2545 | FILE *fp=fopen(fn, "wb"); |
---|
2546 | if (!fp) |
---|
2547 | lbreak("could not open %s for writing", fn); |
---|
2548 | else |
---|
2549 | { |
---|
2550 | for (void *s=symbol_list;s;s=CDR(s)) |
---|
2551 | fprintf(fp, "%8d %s\n", ((LispSymbol *)(CAR(s)))->call_counter, |
---|
2552 | lstring_value(((LispSymbol *)(CAR(s)))->name)); |
---|
2553 | fclose(fp); |
---|
2554 | } |
---|
2555 | } break;*/ |
---|
2556 | case SYS_FUNC_FOR: |
---|
2557 | { |
---|
2558 | void *bind_var=CAR(arg_list); arg_list=CDR(arg_list); |
---|
2559 | p_ref r1(bind_var); |
---|
2560 | if (item_type(bind_var)!=L_SYMBOL) |
---|
2561 | { lbreak("expecting for iterator to be a symbol\n"); exit(1); } |
---|
2562 | |
---|
2563 | if (CAR(arg_list)!=in_symbol) |
---|
2564 | { lbreak("expecting in after 'for iterator'\n"); exit(1); } |
---|
2565 | arg_list=CDR(arg_list); |
---|
2566 | |
---|
2567 | void *ilist=eval(CAR(arg_list)); arg_list=CDR(arg_list); |
---|
2568 | p_ref r2(ilist); |
---|
2569 | |
---|
2570 | if (CAR(arg_list)!=do_symbol) |
---|
2571 | { lbreak("expecting do after 'for iterator in list'\n"); exit(1); } |
---|
2572 | arg_list=CDR(arg_list); |
---|
2573 | |
---|
2574 | void *block=NULL, *ret=NULL; |
---|
2575 | p_ref r3(block); |
---|
2576 | l_user_stack.push(symbol_value(bind_var)); // save old symbol value |
---|
2577 | while (ilist) |
---|
2578 | { |
---|
2579 | set_symbol_value(bind_var, CAR(ilist)); |
---|
2580 | for (block=arg_list;block;block=CDR(block)) |
---|
2581 | ret=eval(CAR(block)); |
---|
2582 | ilist=CDR(ilist); |
---|
2583 | } |
---|
2584 | set_symbol_value(bind_var, l_user_stack.pop(1)); |
---|
2585 | ret=ret; |
---|
2586 | } break; |
---|
2587 | case SYS_FUNC_OPEN_FILE: |
---|
2588 | { |
---|
2589 | bFILE *old_file=current_print_file; |
---|
2590 | void *str1=eval(CAR(arg_list)); |
---|
2591 | p_ref r1(str1); |
---|
2592 | void *str2=eval(CAR(CDR(arg_list))); |
---|
2593 | |
---|
2594 | |
---|
2595 | current_print_file=open_file(lstring_value(str1), |
---|
2596 | lstring_value(str2)); |
---|
2597 | |
---|
2598 | if (!current_print_file->open_failure()) |
---|
2599 | { |
---|
2600 | while (arg_list) |
---|
2601 | { |
---|
2602 | ret=eval(CAR(arg_list)); |
---|
2603 | arg_list=CDR(arg_list); |
---|
2604 | } |
---|
2605 | } |
---|
2606 | delete current_print_file; |
---|
2607 | current_print_file=old_file; |
---|
2608 | |
---|
2609 | } break; |
---|
2610 | case SYS_FUNC_BIT_AND: |
---|
2611 | { |
---|
2612 | long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2613 | while (arg_list) |
---|
2614 | { |
---|
2615 | first&=lnumber_value(eval(CAR(arg_list))); |
---|
2616 | arg_list=CDR(arg_list); |
---|
2617 | } |
---|
2618 | ret=new_lisp_number(first); |
---|
2619 | } break; |
---|
2620 | case SYS_FUNC_BIT_OR: |
---|
2621 | { |
---|
2622 | long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2623 | while (arg_list) |
---|
2624 | { |
---|
2625 | first|=lnumber_value(eval(CAR(arg_list))); |
---|
2626 | arg_list=CDR(arg_list); |
---|
2627 | } |
---|
2628 | ret=new_lisp_number(first); |
---|
2629 | } break; |
---|
2630 | case SYS_FUNC_BIT_XOR: |
---|
2631 | { |
---|
2632 | long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2633 | while (arg_list) |
---|
2634 | { |
---|
2635 | first^=lnumber_value(eval(CAR(arg_list))); |
---|
2636 | arg_list=CDR(arg_list); |
---|
2637 | } |
---|
2638 | ret=new_lisp_number(first); |
---|
2639 | } break; |
---|
2640 | case SYS_FUNC_MAKE_ARRAY: |
---|
2641 | { |
---|
2642 | long l=lnumber_value(eval(CAR(arg_list))); |
---|
2643 | if (l>=2<<16 || l<=0) |
---|
2644 | { |
---|
2645 | lbreak("bad array size %d\n", l); |
---|
2646 | exit(0); |
---|
2647 | } |
---|
2648 | ret=new_lisp_1d_array(l, CDR(arg_list)); |
---|
2649 | } break; |
---|
2650 | case SYS_FUNC_AREF: |
---|
2651 | { |
---|
2652 | long x=lnumber_value(eval(CAR(CDR(arg_list)))); |
---|
2653 | ret=lget_array_element(eval(CAR(arg_list)), x); |
---|
2654 | } break; |
---|
2655 | case SYS_FUNC_IF_1PROGN: |
---|
2656 | { |
---|
2657 | if (eval(CAR(arg_list))) |
---|
2658 | ret=eval_block(CAR(CDR(arg_list))); |
---|
2659 | else ret=eval(CAR(CDR(CDR(arg_list)))); |
---|
2660 | |
---|
2661 | } break; |
---|
2662 | case SYS_FUNC_IF_2PROGN: |
---|
2663 | { |
---|
2664 | if (eval(CAR(arg_list))) |
---|
2665 | ret=eval(CAR(CDR(arg_list))); |
---|
2666 | else ret=eval_block(CAR(CDR(CDR(arg_list)))); |
---|
2667 | |
---|
2668 | } break; |
---|
2669 | case SYS_FUNC_IF_12PROGN: |
---|
2670 | { |
---|
2671 | if (eval(CAR(arg_list))) |
---|
2672 | ret=eval_block(CAR(CDR(arg_list))); |
---|
2673 | else ret=eval_block(CAR(CDR(CDR(arg_list)))); |
---|
2674 | |
---|
2675 | } break; |
---|
2676 | case SYS_FUNC_EQ0: |
---|
2677 | { |
---|
2678 | void *v=eval(CAR(arg_list)); |
---|
2679 | if (item_type(v)!=L_NUMBER || (((LispNumber *)v)->num!=0)) |
---|
2680 | ret=NULL; |
---|
2681 | else ret=true_symbol; |
---|
2682 | } break; |
---|
2683 | case SYS_FUNC_PREPORT: |
---|
2684 | { |
---|
2685 | #ifdef L_PROFILE |
---|
2686 | char *s=lstring_value(eval(CAR(arg_list))); |
---|
2687 | preport(s); |
---|
2688 | #endif |
---|
2689 | } break; |
---|
2690 | case SYS_FUNC_SEARCH: |
---|
2691 | { |
---|
2692 | void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list); |
---|
2693 | p_ref r1(arg1); // protect this refrence |
---|
2694 | char *haystack=lstring_value(eval(CAR(arg_list))); |
---|
2695 | char *needle=lstring_value(arg1); |
---|
2696 | |
---|
2697 | char *find=strstr(haystack, needle); |
---|
2698 | if (find) |
---|
2699 | ret=new_lisp_number(find-haystack); |
---|
2700 | else ret=NULL; |
---|
2701 | } break; |
---|
2702 | case SYS_FUNC_ELT: |
---|
2703 | { |
---|
2704 | void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list); |
---|
2705 | p_ref r1(arg1); // protect this refrence |
---|
2706 | long x=lnumber_value(eval(CAR(arg_list))); |
---|
2707 | char *st=lstring_value(arg1); |
---|
2708 | if (x < 0 || (unsigned)x >= strlen(st)) |
---|
2709 | { lbreak("elt : out of range of string\n"); ret=NULL; } |
---|
2710 | else |
---|
2711 | ret=new_lisp_character(st[x]); |
---|
2712 | } break; |
---|
2713 | case SYS_FUNC_LISTP: |
---|
2714 | { |
---|
2715 | return item_type(eval(CAR(arg_list)))==L_CONS_CELL ? true_symbol : NULL; |
---|
2716 | } break; |
---|
2717 | case SYS_FUNC_NUMBERP: |
---|
2718 | { |
---|
2719 | int t=item_type(eval(CAR(arg_list))); |
---|
2720 | if (t==L_NUMBER || t==L_FIXED_POINT) return true_symbol; else return NULL; |
---|
2721 | } break; |
---|
2722 | case SYS_FUNC_DO: |
---|
2723 | { |
---|
2724 | void *init_var=CAR(arg_list); |
---|
2725 | p_ref r1(init_var); |
---|
2726 | int i, ustack_start=l_user_stack.son; // restore stack at end |
---|
2727 | void *sym=NULL; |
---|
2728 | p_ref r2(sym); |
---|
2729 | |
---|
2730 | // check to make sure iter vars are symbol and push old values |
---|
2731 | for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var)) |
---|
2732 | { |
---|
2733 | sym=CAR(CAR(init_var)); |
---|
2734 | if (item_type(sym)!=L_SYMBOL) |
---|
2735 | { lbreak("expecting symbol name for iteration var\n"); exit(0); } |
---|
2736 | l_user_stack.push(symbol_value(sym)); |
---|
2737 | } |
---|
2738 | |
---|
2739 | void **do_evaled=l_user_stack.sdata+l_user_stack.son; |
---|
2740 | // push all of the init forms, so we can set the symbol |
---|
2741 | for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var)) |
---|
2742 | l_user_stack.push(eval(CAR(CDR(CAR((init_var)))))); |
---|
2743 | |
---|
2744 | // now set all the symbols |
---|
2745 | for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var), do_evaled++) |
---|
2746 | { |
---|
2747 | sym=CAR(CAR(init_var)); |
---|
2748 | set_symbol_value(sym, *do_evaled); |
---|
2749 | } |
---|
2750 | |
---|
2751 | i=0; // set i to 1 when terminate conditions are meet |
---|
2752 | do |
---|
2753 | { |
---|
2754 | i=(eval(CAR(CAR(CDR(arg_list))))!=NULL); |
---|
2755 | if (!i) |
---|
2756 | { |
---|
2757 | eval_block(CDR(CDR(arg_list))); |
---|
2758 | for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var)) |
---|
2759 | eval(CAR(CDR(CDR(CAR(init_var))))); |
---|
2760 | } |
---|
2761 | } while (!i); |
---|
2762 | |
---|
2763 | ret=eval(CAR(CDR(CAR(CDR(arg_list))))); |
---|
2764 | |
---|
2765 | // restore old values for symbols |
---|
2766 | do_evaled=l_user_stack.sdata+ustack_start; |
---|
2767 | for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var), do_evaled++) |
---|
2768 | { |
---|
2769 | sym=CAR(CAR(init_var)); |
---|
2770 | set_symbol_value(sym, *do_evaled); |
---|
2771 | } |
---|
2772 | |
---|
2773 | l_user_stack.son=ustack_start; |
---|
2774 | |
---|
2775 | } break; |
---|
2776 | case SYS_FUNC_GC: |
---|
2777 | { |
---|
2778 | collect_space(current_space); |
---|
2779 | } break; |
---|
2780 | case SYS_FUNC_SCHAR: |
---|
2781 | { |
---|
2782 | char *s=lstring_value(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2783 | long x=lnumber_value(eval(CAR(arg_list))); |
---|
2784 | |
---|
2785 | if ((unsigned)x >= strlen(s)) |
---|
2786 | { lbreak("SCHAR: index %d should be less than the length of the string\n", x); exit(0); } |
---|
2787 | else if (x<0) |
---|
2788 | { lbreak("SCHAR: index should not be negative\n"); exit(0); } |
---|
2789 | return new_lisp_character(s[x]); |
---|
2790 | } break; |
---|
2791 | case SYS_FUNC_SYMBOLP: |
---|
2792 | { if (item_type(eval(CAR(arg_list)))==L_SYMBOL) return true_symbol; |
---|
2793 | else return NULL; } break; |
---|
2794 | case SYS_FUNC_NUM2STR: |
---|
2795 | { |
---|
2796 | char str[20]; |
---|
2797 | sprintf(str, "%ld", (long int)lnumber_value(eval(CAR(arg_list)))); |
---|
2798 | ret=new_lisp_string(str); |
---|
2799 | } break; |
---|
2800 | case SYS_FUNC_NCONC: |
---|
2801 | { |
---|
2802 | void *l1=eval(CAR(arg_list)); arg_list=CDR(arg_list); |
---|
2803 | p_ref r1(l1); |
---|
2804 | void *first=l1, *next; |
---|
2805 | p_ref r2(first); |
---|
2806 | |
---|
2807 | if (!l1) |
---|
2808 | { |
---|
2809 | l1=first=eval(CAR(arg_list)); |
---|
2810 | arg_list=CDR(arg_list); |
---|
2811 | } |
---|
2812 | |
---|
2813 | if (item_type(l1)!=L_CONS_CELL) |
---|
2814 | { lprint(l1); lbreak("first arg should be a list\n"); } |
---|
2815 | do |
---|
2816 | { |
---|
2817 | next=l1; |
---|
2818 | while (next) { l1=next; next=lcdr(next); } |
---|
2819 | ((LispList *)l1)->cdr=eval(CAR(arg_list)); |
---|
2820 | arg_list=CDR(arg_list); |
---|
2821 | } while (arg_list); |
---|
2822 | ret=first; |
---|
2823 | } break; |
---|
2824 | case SYS_FUNC_FIRST: |
---|
2825 | { ret=CAR(eval(CAR(arg_list))); } break; |
---|
2826 | case SYS_FUNC_SECOND: |
---|
2827 | { ret=CAR(CDR(eval(CAR(arg_list)))); } break; |
---|
2828 | case SYS_FUNC_THIRD: |
---|
2829 | { ret=CAR(CDR(CDR(eval(CAR(arg_list))))); } break; |
---|
2830 | case SYS_FUNC_FOURTH: |
---|
2831 | { ret=CAR(CDR(CDR(CDR(eval(CAR(arg_list)))))); } break; |
---|
2832 | case SYS_FUNC_FIFTH: |
---|
2833 | { ret=CAR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))); } break; |
---|
2834 | case SYS_FUNC_SIXTH: |
---|
2835 | { ret=CAR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))); } break; |
---|
2836 | case SYS_FUNC_SEVENTH: |
---|
2837 | { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))))); } break; |
---|
2838 | case SYS_FUNC_EIGHTH: |
---|
2839 | { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))))); } break; |
---|
2840 | case SYS_FUNC_NINTH: |
---|
2841 | { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))))))); } break; |
---|
2842 | case SYS_FUNC_TENTH: |
---|
2843 | { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))))))); } break; |
---|
2844 | case SYS_FUNC_SUBSTR: |
---|
2845 | { |
---|
2846 | long x1=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2847 | long x2=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list); |
---|
2848 | void *st=eval(CAR(arg_list)); |
---|
2849 | p_ref r1(st); |
---|
2850 | |
---|
2851 | if (x1 < 0 || x1 > x2 || (unsigned)x2 >= strlen(lstring_value(st))) |
---|
2852 | lbreak("substr : bad x1 or x2 value"); |
---|
2853 | |
---|
2854 | LispString *s=new_lisp_string(x2-x1+2); |
---|
2855 | if (x2-x1) |
---|
2856 | memcpy(lstring_value(s), lstring_value(st)+x1, x2-x1+1); |
---|
2857 | |
---|
2858 | *(lstring_value(s)+(x2-x1+1))=0; |
---|
2859 | ret=s; |
---|
2860 | } break; |
---|
2861 | case 99 : |
---|
2862 | { |
---|
2863 | void *r=NULL, *rstart=NULL; |
---|
2864 | p_ref r1(r), r2(rstart); |
---|
2865 | while (arg_list) |
---|
2866 | { |
---|
2867 | void *q=eval(CAR(arg_list)); |
---|
2868 | if (!rstart) rstart=q; |
---|
2869 | while (r && CDR(r)) r=CDR(r); |
---|
2870 | CDR(r)=q; |
---|
2871 | arg_list=CDR(arg_list); |
---|
2872 | } |
---|
2873 | return rstart; |
---|
2874 | } break; |
---|
2875 | |
---|
2876 | default : |
---|
2877 | { dprintf("Undefined system function number %d\n", ((LispSysFunction *)fun)->fun_number); } |
---|
2878 | } |
---|
2879 | return ret; |
---|
2880 | } |
---|
2881 | |
---|
2882 | void tmp_space() |
---|
2883 | { |
---|
2884 | current_space=TMP_SPACE; |
---|
2885 | } |
---|
2886 | |
---|
2887 | void perm_space() |
---|
2888 | { |
---|
2889 | current_space=PERM_SPACE; |
---|
2890 | } |
---|
2891 | |
---|
2892 | void use_user_space(void *addr, long size) |
---|
2893 | { |
---|
2894 | current_space = 2; |
---|
2895 | free_space[USER_SPACE] = space[USER_SPACE] = (uint8_t *)addr; |
---|
2896 | space_size[USER_SPACE] = size; |
---|
2897 | } |
---|
2898 | |
---|
2899 | |
---|
2900 | void *eval_user_fun(LispSymbol *sym, void *arg_list) |
---|
2901 | { |
---|
2902 | void *ret=NULL; |
---|
2903 | p_ref ref1(ret); |
---|
2904 | |
---|
2905 | #ifdef TYPE_CHECKING |
---|
2906 | if (item_type(sym)!=L_SYMBOL) |
---|
2907 | { |
---|
2908 | lprint(sym); |
---|
2909 | lbreak("EVAL : is not a function name (not symbol either)"); |
---|
2910 | exit(0); |
---|
2911 | } |
---|
2912 | #endif |
---|
2913 | #ifdef L_PROFILE |
---|
2914 | time_marker start; |
---|
2915 | #endif |
---|
2916 | |
---|
2917 | |
---|
2918 | LispUserFunction *fun=(LispUserFunction *)(((LispSymbol *)sym)->function); |
---|
2919 | |
---|
2920 | #ifdef TYPE_CHECKING |
---|
2921 | if (item_type(fun)!=L_USER_FUNCTION) |
---|
2922 | { |
---|
2923 | lprint(sym); |
---|
2924 | lbreak("is not a user defined function\n"); |
---|
2925 | } |
---|
2926 | #endif |
---|
2927 | |
---|
2928 | #ifndef NO_LIBS |
---|
2929 | void *fun_arg_list=cache.lblock(fun->alist); |
---|
2930 | void *block_list=cache.lblock(fun->blist); |
---|
2931 | p_ref r9(block_list), r10(fun_arg_list); |
---|
2932 | #else |
---|
2933 | void *fun_arg_list=fun->arg_list; |
---|
2934 | void *block_list=fun->block_list; |
---|
2935 | p_ref r9(block_list), r10(fun_arg_list); |
---|
2936 | #endif |
---|
2937 | |
---|
2938 | |
---|
2939 | |
---|
2940 | // mark the start start, so we can restore when done |
---|
2941 | long stack_start=l_user_stack.son; |
---|
2942 | |
---|
2943 | // first push all of the old symbol values |
---|
2944 | void *f_arg=fun_arg_list; |
---|
2945 | p_ref r18(f_arg); |
---|
2946 | p_ref r19(arg_list); |
---|
2947 | for (;f_arg;f_arg=CDR(f_arg)) |
---|
2948 | { |
---|
2949 | LispSymbol *s = (LispSymbol *)CAR(f_arg); |
---|
2950 | l_user_stack.push(s->value); |
---|
2951 | } |
---|
2952 | |
---|
2953 | // open block so that local vars aren't saved on the stack |
---|
2954 | { |
---|
2955 | int new_start=l_user_stack.son; |
---|
2956 | int i=new_start; |
---|
2957 | // now push all the values we wish to gather |
---|
2958 | for (f_arg=fun_arg_list;f_arg;) |
---|
2959 | { |
---|
2960 | if (!arg_list) |
---|
2961 | { lprint(sym); lbreak("too few parameter to function\n"); exit(0); } |
---|
2962 | l_user_stack.push(eval(CAR(arg_list))); |
---|
2963 | f_arg=CDR(f_arg); |
---|
2964 | arg_list=CDR(arg_list); |
---|
2965 | } |
---|
2966 | |
---|
2967 | |
---|
2968 | // now store all the values and put them into the symbols |
---|
2969 | for (f_arg=fun_arg_list;f_arg;f_arg=CDR(f_arg)) |
---|
2970 | ((LispSymbol *)CAR(f_arg))->value=l_user_stack.sdata[i++]; |
---|
2971 | |
---|
2972 | l_user_stack.son=new_start; |
---|
2973 | } |
---|
2974 | |
---|
2975 | |
---|
2976 | |
---|
2977 | if (f_arg) |
---|
2978 | { lprint(sym); lbreak("too many parameter to function\n"); exit(0); } |
---|
2979 | |
---|
2980 | |
---|
2981 | // now evaluate the function block |
---|
2982 | while (block_list) |
---|
2983 | { |
---|
2984 | ret=eval(CAR(block_list)); |
---|
2985 | block_list=CDR(block_list); |
---|
2986 | } |
---|
2987 | |
---|
2988 | long cur_stack=stack_start; |
---|
2989 | for (f_arg=fun_arg_list;f_arg;f_arg=CDR(f_arg)) |
---|
2990 | ((LispSymbol *)CAR(f_arg))->value=l_user_stack.sdata[cur_stack++]; |
---|
2991 | |
---|
2992 | l_user_stack.son=stack_start; |
---|
2993 | |
---|
2994 | #ifdef L_PROFILE |
---|
2995 | time_marker end; |
---|
2996 | ((LispSymbol *)sym)->time_taken+=end.diff_time(&start); |
---|
2997 | #endif |
---|
2998 | |
---|
2999 | |
---|
3000 | return ret; |
---|
3001 | } |
---|
3002 | |
---|
3003 | |
---|
3004 | |
---|
3005 | |
---|
3006 | |
---|
3007 | void *eval(void *prog) |
---|
3008 | { |
---|
3009 | |
---|
3010 | |
---|
3011 | void *ret=NULL; |
---|
3012 | p_ref ref1(prog); |
---|
3013 | |
---|
3014 | |
---|
3015 | int tstart=trace_level; |
---|
3016 | |
---|
3017 | if (trace_level) |
---|
3018 | { |
---|
3019 | if (trace_level<=trace_print_level) |
---|
3020 | { |
---|
3021 | dprintf("%d (%d, %d, %d) TRACE : ", trace_level, |
---|
3022 | space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]), |
---|
3023 | space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]), |
---|
3024 | l_ptr_stack.son); |
---|
3025 | lprint(prog); |
---|
3026 | |
---|
3027 | dprintf("\n"); |
---|
3028 | } |
---|
3029 | trace_level++; |
---|
3030 | } |
---|
3031 | if (prog) |
---|
3032 | { |
---|
3033 | switch (item_type(prog)) |
---|
3034 | { |
---|
3035 | case L_BAD_CELL : |
---|
3036 | { lbreak("error : eval on a bad cell\n"); exit(0); } break; |
---|
3037 | case L_CHARACTER : |
---|
3038 | case L_STRING : |
---|
3039 | case L_NUMBER : |
---|
3040 | case L_POINTER : |
---|
3041 | case L_FIXED_POINT : |
---|
3042 | { ret=prog; } break; |
---|
3043 | case L_SYMBOL : |
---|
3044 | { if (prog==true_symbol) |
---|
3045 | ret=prog; |
---|
3046 | else |
---|
3047 | { |
---|
3048 | ret=lookup_symbol_value(prog); |
---|
3049 | if (item_type(ret)==L_OBJECT_VAR) |
---|
3050 | ret=l_obj_get(((LispObjectVar *)ret)->number); |
---|
3051 | } |
---|
3052 | } break; |
---|
3053 | case L_CONS_CELL : |
---|
3054 | { |
---|
3055 | ret=eval_function((LispSymbol *)CAR(prog), CDR(prog)); |
---|
3056 | } |
---|
3057 | break; |
---|
3058 | default : |
---|
3059 | fprintf(stderr, "shouldn't happen\n"); |
---|
3060 | } |
---|
3061 | } |
---|
3062 | if (tstart) |
---|
3063 | { |
---|
3064 | trace_level--; |
---|
3065 | if (trace_level<=trace_print_level) |
---|
3066 | dprintf("%d (%d, %d, %d) TRACE ==> ", trace_level, |
---|
3067 | space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]), |
---|
3068 | space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]), |
---|
3069 | l_ptr_stack.son); |
---|
3070 | lprint(ret); |
---|
3071 | dprintf("\n"); |
---|
3072 | } |
---|
3073 | |
---|
3074 | /* l_user_stack.push(ret); |
---|
3075 | collect_space(PERM_SPACE); |
---|
3076 | ret=l_user_stack.pop(1); */ |
---|
3077 | |
---|
3078 | |
---|
3079 | return ret; |
---|
3080 | } |
---|
3081 | |
---|
3082 | int total_symbols() |
---|
3083 | { |
---|
3084 | return ltotal_syms; |
---|
3085 | } |
---|
3086 | |
---|
3087 | void resize_perm(int new_size) |
---|
3088 | { |
---|
3089 | if (new_size<((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE])) |
---|
3090 | { |
---|
3091 | lbreak("resize perm : %d is to small to hold current heap\n", new_size); |
---|
3092 | exit(0); |
---|
3093 | } else if (new_size>space_size[PERM_SPACE]) |
---|
3094 | { |
---|
3095 | lbreak("Only smaller resizes allowed for now.\n"); |
---|
3096 | exit(0); |
---|
3097 | } else |
---|
3098 | dprintf("doesn't work yet!\n"); |
---|
3099 | } |
---|
3100 | |
---|
3101 | void resize_tmp(int new_size) |
---|
3102 | { |
---|
3103 | if (new_size<((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE])) |
---|
3104 | { |
---|
3105 | lbreak("resize perm : %d is to small to hold current heap\n", new_size); |
---|
3106 | exit(0); |
---|
3107 | } else if (new_size>space_size[TMP_SPACE]) |
---|
3108 | { |
---|
3109 | printf("Only smaller resizes allowed for now.\n"); |
---|
3110 | exit(0); |
---|
3111 | } else if (free_space[TMP_SPACE]==space[TMP_SPACE]) |
---|
3112 | { |
---|
3113 | free_space[TMP_SPACE] = space[TMP_SPACE] = (uint8_t *)realloc(space[TMP_SPACE], new_size); |
---|
3114 | space_size[TMP_SPACE] = new_size; |
---|
3115 | dprintf("Lisp : tmp space resized to %d\n", new_size); |
---|
3116 | } else dprintf("Lisp :tmp not empty, cannot resize\n"); |
---|
3117 | } |
---|
3118 | |
---|
3119 | void l_comp_init(); |
---|
3120 | void lisp_init(long perm_size, long tmp_size) |
---|
3121 | { |
---|
3122 | unsigned int i; |
---|
3123 | lsym_root = NULL; |
---|
3124 | total_user_functions = 0; |
---|
3125 | |
---|
3126 | free_space[0] = space[0] = (uint8_t *)malloc(perm_size); |
---|
3127 | space_size[0] = perm_size; |
---|
3128 | |
---|
3129 | free_space[1] = space[1] = (uint8_t *)malloc(tmp_size); |
---|
3130 | space_size[1] = tmp_size; |
---|
3131 | |
---|
3132 | |
---|
3133 | current_space=PERM_SPACE; |
---|
3134 | |
---|
3135 | |
---|
3136 | l_comp_init(); |
---|
3137 | for(i = 0; i < sizeof(sys_funcs) / sizeof(*sys_funcs); i++) |
---|
3138 | add_sys_function(sys_funcs[i].name, |
---|
3139 | sys_funcs[i].min_args, sys_funcs[i].max_args, i); |
---|
3140 | clisp_init(); |
---|
3141 | current_space=TMP_SPACE; |
---|
3142 | dprintf("Lisp : %d symbols defined, %d system functions, %d pre-compiled functions\n", |
---|
3143 | total_symbols(), sizeof(sys_funcs) / sizeof(*sys_funcs), total_user_functions); |
---|
3144 | } |
---|
3145 | |
---|
3146 | void lisp_uninit() |
---|
3147 | { |
---|
3148 | free(space[0]); |
---|
3149 | free(space[1]); |
---|
3150 | ldelete_syms(lsym_root); |
---|
3151 | lsym_root=NULL; |
---|
3152 | ltotal_syms=0; |
---|
3153 | } |
---|
3154 | |
---|
3155 | void clear_tmp() |
---|
3156 | { |
---|
3157 | free_space[TMP_SPACE]=space[TMP_SPACE]; |
---|
3158 | } |
---|
3159 | |
---|
3160 | void *symbol_name(void *symbol) |
---|
3161 | { |
---|
3162 | return ((LispSymbol *)symbol)->name; |
---|
3163 | } |
---|
3164 | |
---|
3165 | |
---|
3166 | void *set_symbol_number(void *symbol, long num) |
---|
3167 | { |
---|
3168 | #ifdef TYPE_CHECKING |
---|
3169 | if (item_type(symbol)!=L_SYMBOL) |
---|
3170 | { |
---|
3171 | lprint(symbol); |
---|
3172 | lbreak("is not a symbol\n"); |
---|
3173 | exit(0); |
---|
3174 | } |
---|
3175 | #endif |
---|
3176 | if (((LispSymbol *)symbol)->value!=l_undefined && |
---|
3177 | item_type(((LispSymbol *)symbol)->value)==L_NUMBER) |
---|
3178 | ((LispNumber *)((LispSymbol *)symbol)->value)->num=num; |
---|
3179 | else |
---|
3180 | ((LispSymbol *)(symbol))->value=new_lisp_number(num); |
---|
3181 | |
---|
3182 | return ((LispSymbol *)(symbol))->value; |
---|
3183 | } |
---|
3184 | |
---|
3185 | void *set_symbol_value(void *symbol, void *value) |
---|
3186 | { |
---|
3187 | #ifdef TYPE_CHECKING |
---|
3188 | if (item_type(symbol)!=L_SYMBOL) |
---|
3189 | { |
---|
3190 | lprint(symbol); |
---|
3191 | lbreak("is not a symbol\n"); |
---|
3192 | exit(0); |
---|
3193 | } |
---|
3194 | #endif |
---|
3195 | ((LispSymbol *)(symbol))->value=value; |
---|
3196 | return value; |
---|
3197 | } |
---|
3198 | |
---|
3199 | void *symbol_function(void *symbol) |
---|
3200 | { |
---|
3201 | #ifdef TYPE_CHECKING |
---|
3202 | if (item_type(symbol)!=L_SYMBOL) |
---|
3203 | { |
---|
3204 | lprint(symbol); |
---|
3205 | lbreak("is not a symbol\n"); |
---|
3206 | exit(0); |
---|
3207 | } |
---|
3208 | #endif |
---|
3209 | return ((LispSymbol *)symbol)->function; |
---|
3210 | } |
---|
3211 | |
---|
3212 | void *symbol_value(void *symbol) |
---|
3213 | { |
---|
3214 | #ifdef TYPE_CHECKING |
---|
3215 | if (item_type(symbol)!=L_SYMBOL) |
---|
3216 | { |
---|
3217 | lprint(symbol); |
---|
3218 | lbreak("is not a symbol\n"); |
---|
3219 | exit(0); |
---|
3220 | } |
---|
3221 | #endif |
---|
3222 | return ((LispSymbol *)symbol)->value; |
---|
3223 | } |
---|
3224 | |
---|
3225 | |
---|
3226 | |
---|
3227 | |
---|
3228 | |
---|
3229 | |
---|