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

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