source: abuse/trunk/src/lisp/lisp.cpp @ 129

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