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

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