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

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