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

Last change on this file since 2 was 2, checked in by Sam Hocevar, 14 years ago
  • imported original 0.7.0 tarball
File size: 78.4 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(ushort 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(long 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(short 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(unsigned short 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  long 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  long 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(long length)
324{
325  long 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(long arg_list, long 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
501long 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 (uchar)*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
562unsigned short 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;
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      ((cons_cell *)cell)->car=lcar(list1);
946      ((cons_cell *)cell)->cdr=lcar(list2);
947      ((cons_cell *)cur)->car=cell;
948
949      list1=((cons_cell *)list1)->cdr;
950      list2=((cons_cell *)list2)->cdr;
951    }
952    ((cons_cell *)cur)->cdr=list3;
953    ret=first;
954  } else ret=NULL;
955  return ret;
956}
957
958void *lookup_symbol_function(void *symbol)
959{
960  return ((lisp_symbol *)symbol)->function;
961}
962
963void set_symbol_function(void *symbol, void *function)
964{
965  ((lisp_symbol *)symbol)->function=function;
966}
967
968void *lookup_symbol_value(void *symbol)
969{
970#ifdef TYPE_CHECKING
971  if (((lisp_symbol *)symbol)->value!=l_undefined)
972#endif
973    return ((lisp_symbol *)symbol)->value;
974#ifdef TYPE_CHECKING
975  else
976  {
977    lprint(symbol);
978    lbreak(" has no value\n");
979    exit(0);
980  }
981#endif
982  return NULL;
983}
984
985void set_variable_value(void *symbol, void *value)
986{
987  ((lisp_symbol *) symbol)->value=value;
988}
989
990lisp_symbol *add_sys_function(char *name, short min_args, short max_args, short number)
991{
992  need_perm_space("add_sys_function");
993  lisp_symbol *s=make_find_symbol(name);
994  if (s->function!=l_undefined)
995  {
996    lbreak("add_sys_fucntion -> symbol %s already has a function\n",name);
997    exit(0);
998  }
999  else s->function=new_lisp_sys_function(min_args,max_args,number);
1000  return s;
1001}
1002
1003lisp_symbol *add_c_object(void *symbol, short number)
1004{
1005  need_perm_space("add_c_object");
1006  lisp_symbol *s=(lisp_symbol *)symbol;
1007  if (s->value!=l_undefined)
1008  {
1009    lbreak("add_c_object -> symbol %s already has a value\n",lstring_value(symbol_name(s)));
1010    exit(0);
1011  }
1012  else s->value=new_lisp_object_var(number);
1013  return NULL;
1014}
1015
1016lisp_symbol *add_c_function(char *name, short min_args, short max_args, short number)
1017{
1018  total_user_functions++;
1019  need_perm_space("add_c_function");
1020  lisp_symbol *s=make_find_symbol(name);
1021  if (s->function!=l_undefined)
1022  {
1023    lbreak("add_sys_fucntion -> symbol %s already has a function\n",name);
1024    exit(0);
1025  }
1026  else s->function=new_lisp_c_function(min_args,max_args,number);
1027  return s;
1028}
1029
1030lisp_symbol *add_c_bool_fun(char *name, short min_args, short max_args, short number)
1031{
1032  total_user_functions++;
1033  need_perm_space("add_c_bool_fun");
1034  lisp_symbol *s=make_find_symbol(name);
1035  if (s->function!=l_undefined)
1036  {
1037    lbreak("add_sys_fucntion -> symbol %s already has a function\n",name);
1038    exit(0);
1039  }
1040  else s->function=new_lisp_c_bool(min_args,max_args,number);
1041  return s;
1042}
1043
1044
1045lisp_symbol *add_lisp_function(char *name, short min_args, short max_args, short number)
1046{
1047  total_user_functions++;
1048  need_perm_space("add_c_bool_fun");
1049  lisp_symbol *s=make_find_symbol(name);
1050  if (s->function!=l_undefined)
1051  {
1052    lbreak("add_sys_fucntion -> symbol %s already has a function\n",name);
1053    exit(0);
1054  }
1055  else s->function=new_user_lisp_function(min_args,max_args,number);
1056  return s;
1057}
1058
1059void skip_c_comment(char *&s)
1060{
1061  s+=2;
1062  while (*s && (*s!='*' || *(s+1)!='/'))
1063  {
1064    if (*s=='/' && *(s+1)=='*')
1065      skip_c_comment(s);
1066    else s++;
1067  }
1068  if (*s) s+=2;
1069}
1070
1071long str_token_len(char *st)
1072{
1073  long x=1;
1074  while (*st && (*st!='"' || st[1]=='"'))
1075  {
1076    if (*st=='\\' || *st=='"') st++;   
1077    st++; x++;
1078  }
1079  return x;
1080}
1081
1082int read_ltoken(char *&s, char *buffer)
1083{
1084  // skip space
1085  while (*s==' ' || *s=='\t' || *s=='\n' || *s=='\r' || *s==26) s++;
1086  if (*s==';')  // comment
1087  {
1088    while (*s && *s!='\n' && *s!='\r' && *s!=26) s++;
1089    return read_ltoken(s,buffer);
1090  } else if  (*s=='/' && *(s+1)=='*')   // c style comment
1091  {
1092    skip_c_comment(s);
1093    return read_ltoken(s,buffer);   
1094  }
1095  else if (*s==0)
1096    return 0;
1097  else if (*s==')' || *s=='(' || *s=='\'' || *s=='`' || *s==',' || *s==26)
1098  {
1099    *(buffer++)=*(s++);
1100    *buffer=0;
1101  } else if (*s=='"')    // string
1102  {
1103    *(buffer++)=*(s++);          // don't read off the string because it
1104                                 // may be to long to fit in the token buffer
1105                                 // so just read the '"' so the compiler knows to scan the rest.
1106    *buffer=0;
1107  } else if (*s=='#')
1108  {
1109    *(buffer++)=*(s++);     
1110    if (*s!='\'')
1111      *(buffer++)=*(s++);     
1112    *buffer=0;
1113  } else
1114  {
1115    while (*s && *s!=')' && *s!='(' && *s!=' ' && *s!='\n' && *s!='\r' && *s!='\t' && *s!=';' && *s!=26)
1116      *(buffer++)=*(s++);     
1117    *buffer=0;
1118  }
1119  return 1;   
1120}
1121
1122
1123char n[MAX_LISP_TOKEN_LEN];  // assume all tokens will be < 200 characters
1124
1125int end_of_program(char *s)
1126{
1127  return !read_ltoken(s,n);
1128}
1129
1130
1131void push_onto_list(void *object, void *&list)
1132{
1133  p_ref r1(object),r2(list);
1134  cons_cell *c=new_cons_cell();
1135  c->car=object;
1136  c->cdr=list;
1137  list=c;
1138}
1139
1140void *comp_optimize(void *list);
1141
1142void *compile(char *&s)
1143{
1144  void *ret=NULL;
1145  if (!read_ltoken(s,n))
1146    lerror(NULL,"unexpected end of program");
1147  if (streq(n,"nil"))
1148    return NULL;
1149  else if (toupper(n[0])=='T' && !n[1])
1150    return true_symbol;
1151  else if (n[0]=='\'')                    // short hand for quote function
1152  {
1153    void *cs=new_cons_cell(),*c2=NULL;
1154    p_ref r1(cs),r2(c2);
1155
1156    ((cons_cell *)cs)->car=quote_symbol;
1157    c2=new_cons_cell();
1158    ((cons_cell *)c2)->car=compile(s);
1159    ((cons_cell *)c2)->cdr=NULL;
1160    ((cons_cell *)cs)->cdr=c2;
1161    ret=cs;
1162  }
1163  else if (n[0]=='`')                    // short hand for backquote function
1164  {
1165    void *cs=new_cons_cell(),*c2=NULL;
1166    p_ref r1(cs),r2(c2);
1167
1168    ((cons_cell *)cs)->car=backquote_symbol;
1169    c2=new_cons_cell();
1170    ((cons_cell *)c2)->car=compile(s);
1171    ((cons_cell *)c2)->cdr=NULL;
1172    ((cons_cell *)cs)->cdr=c2;
1173    ret=cs;
1174  }  else if (n[0]==',')              // short hand for comma function
1175  {
1176    void *cs=new_cons_cell(),*c2=NULL;
1177    p_ref r1(cs),r2(c2);
1178
1179    ((cons_cell *)cs)->car=comma_symbol;
1180    c2=new_cons_cell();
1181    ((cons_cell *)c2)->car=compile(s);
1182    ((cons_cell *)c2)->cdr=NULL;
1183    ((cons_cell *)cs)->cdr=c2;
1184    ret=cs;
1185  }
1186  else if (n[0]=='(')                     // make a list of everything in ()
1187  {
1188    void *first=NULL,*cur=NULL,*last=NULL;   
1189    p_ref r1(first),r2(cur),r3(last);
1190    int done=0;
1191    do
1192    {
1193      char *tmp=s;
1194      if (!read_ltoken(tmp,n))           // check for the end of the list
1195        lerror(NULL,"unexpected end of program");
1196      if (n[0]==')')
1197      {
1198                                done=1;
1199                                read_ltoken(s,n);                // read off the ')'
1200      }
1201      else
1202      {     
1203                                if (n[0]=='.' && !n[1])
1204                                {
1205                                  if (!first)
1206                                    lerror(s,"token '.' not allowed here\n");         
1207                                  else
1208                                  {
1209                                    read_ltoken(s,n);              // skip the '.'
1210                                    ((cons_cell *)last)->cdr=compile(s);          // link the last cdr to
1211                                    last=NULL;
1212                                  }
1213                                } else if (!last && first)
1214                                  lerror(s,"illegal end of dotted list\n");
1215                                else
1216                                {               
1217                                  cur=new_cons_cell();
1218                                  p_ref r1(cur);
1219                                  if (!first) first=cur;
1220                                  ((cons_cell *)cur)->car=compile(s);   
1221                                  if (last)
1222                                    ((cons_cell *)last)->cdr=cur;
1223                                  last=cur;
1224                                }
1225      }
1226    } while (!done);
1227    ret=comp_optimize(first);
1228
1229  } else if (n[0]==')')
1230    lerror(s,"mismatched )");
1231  else if (isdigit(n[0]) || (n[0]=='-' && isdigit(n[1])))
1232  {
1233    lisp_number *num=new_lisp_number(0);
1234    sscanf(n,"%ld",&num->num);
1235    ret=num;
1236  } else if (n[0]=='"')
1237  {
1238    ret=new_lisp_string(str_token_len(s));
1239    char *start=lstring_value(ret);
1240    for (;*s && (*s!='"' || s[1]=='"');s++,start++)
1241    {
1242      if (*s=='\\')
1243      {
1244                                s++;
1245                                if (*s=='n') *start='\n';
1246                                if (*s=='r') *start='\r';
1247                                if (*s=='t') *start='\t';
1248                                if (*s=='\\') *start='\\';
1249      } else *start=*s;
1250      if (*s=='"') s++;
1251    }
1252    *start=0;
1253    s++;
1254  } else if (n[0]=='#')
1255  {
1256    if (n[1]=='\\')
1257    {
1258      read_ltoken(s,n);                   // read character name
1259      if (streq(n,"newline"))
1260        ret=new_lisp_character('\n');
1261      else if (streq(n,"space"))
1262        ret=new_lisp_character(' ');       
1263      else
1264        ret=new_lisp_character(n[0]);       
1265    }
1266    else if (n[1]==0)                           // short hand for function
1267    {
1268      void *cs=new_cons_cell(),*c2=NULL;
1269      p_ref r4(cs),r5(c2);
1270      ((cons_cell *)cs)->car=make_find_symbol("function");
1271      c2=new_cons_cell();
1272      ((cons_cell *)c2)->car=compile(s);
1273      ((cons_cell *)cs)->cdr=c2;
1274      ret=cs;
1275    }
1276    else
1277    {
1278      lbreak("Unknown #\\ notation : %s\n",n);
1279      exit(0);
1280    }
1281  } else return make_find_symbol(n);
1282  return ret;
1283}
1284
1285
1286static void lprint_string(char *st)
1287{
1288  if (current_print_file)
1289  {
1290    for (char *s=st;*s;s++)
1291    {
1292/*      if (*s=='\\')
1293      {
1294        s++;
1295        if (*s=='n')
1296          current_print_file->write_byte('\n');
1297        else if (*s=='r')
1298          current_print_file->write_byte('\r');
1299        else if (*s=='t')
1300          current_print_file->write_byte('\t');
1301        else if (*s=='\\')
1302          current_print_file->write_byte('\\');
1303      }
1304      else*/
1305        current_print_file->write_byte(*s);
1306    }
1307  }
1308  else
1309    dprintf(st);
1310}
1311
1312void lprint(void *i)
1313{
1314  print_level++;
1315  if (!i)
1316    lprint_string("nil");
1317  else
1318  {
1319    switch ((short)item_type(i))
1320    {     
1321      case L_CONS_CELL :
1322      {
1323                                cons_cell *cs=(cons_cell *)i;
1324        lprint_string("(");
1325        for (;cs;cs=(cons_cell *)lcdr(cs))     
1326                                {
1327                                  if (item_type(cs)==(ltype)L_CONS_CELL)
1328                                  {
1329                                    lprint(cs->car);
1330                                    if (cs->cdr)
1331                                      lprint_string(" ");
1332                                  }
1333                                  else
1334                                  {
1335                                    lprint_string(". ");
1336                                    lprint(cs);
1337                                    cs=NULL;
1338                                  }
1339                                }
1340        lprint_string(")");
1341      }
1342      break;
1343      case L_NUMBER :
1344      {
1345                                char num[10];
1346                                sprintf(num,"%ld",((lisp_number *)i)->num);
1347        lprint_string(num);
1348      }
1349      break;
1350      case L_SYMBOL :       
1351        lprint_string((char *)(((lisp_symbol *)i)->name)+sizeof(lisp_string));
1352      break;
1353      case L_USER_FUNCTION :
1354      case L_SYS_FUNCTION :     
1355        lprint_string("err... function?");
1356      break;
1357      case L_C_FUNCTION :
1358        lprint_string("C function, returns number\n");
1359      break;
1360      case L_C_BOOL :
1361        lprint_string("C boolean function\n");
1362      break;
1363      case L_L_FUNCTION :
1364        lprint_string("External lisp function\n");
1365                        break;
1366      case L_STRING :
1367      {
1368                                if (current_print_file)
1369                                        lprint_string(lstring_value(i));
1370                                else
1371                dprintf("\"%s\"",lstring_value(i));
1372      }
1373      break;
1374
1375      case L_POINTER :
1376      {
1377                                char ptr[10];
1378                                sprintf(ptr,"%p",lpointer_value(i));
1379                                lprint_string(ptr);
1380      }
1381      break;
1382      case L_FIXED_POINT :
1383      {
1384                                char num[20];
1385                                sprintf(num,"%g",(lfixed_point_value(i)>>16)+
1386                                              ((lfixed_point_value(i)&0xffff))/(double)0x10000);
1387                                lprint_string(num);
1388      } break;
1389      case L_CHARACTER :
1390      {
1391                                if (current_print_file)
1392                                {
1393                                  uchar ch=((lisp_character *)i)->ch;
1394                                  current_print_file->write(&ch,1);
1395                                } else
1396                                {
1397                                  unsigned short ch=((lisp_character *)i)->ch;
1398                                  dprintf("#\\");
1399                                  switch (ch)
1400                                  {
1401                                    case '\n' :
1402                                    { dprintf("newline"); break; }
1403                                    case ' ' :
1404                                    { dprintf("space"); break; }
1405                                    default :
1406                                      dprintf("%c",ch);
1407                                  }
1408                                }       
1409      } break;
1410      case L_OBJECT_VAR :
1411      {
1412                                l_obj_print(((lisp_object_var *)i)->number);
1413      } break;
1414      case L_1D_ARRAY :
1415      {
1416                                lisp_1d_array *a=(lisp_1d_array *)i;
1417                                void **data=(void **)(a+1);
1418                                dprintf("#(");
1419                                for (int j=0;j<a->size;j++)
1420                                {
1421                                  lprint(data[j]);
1422                                  if (j!=a->size-1)
1423                                    dprintf(" ");
1424                                }
1425                                dprintf(")");
1426      } break;
1427      case L_COLLECTED_OBJECT :
1428      {
1429                                lprint_string("GC_refrence->");
1430                                lprint(((lisp_collected_object *)i)->new_reference);
1431      } break;
1432      default :
1433        dprintf("Shouldn't happen\n");
1434    }
1435  }
1436  print_level--;
1437  if (!print_level && !current_print_file)
1438    dprintf("\n");
1439}
1440
1441void *eval(void *prog);
1442
1443void *eval_sys_function(lisp_sys_function *fun, void *arg_list);
1444
1445void *eval_function(lisp_symbol *sym, void *arg_list)
1446{
1447
1448
1449#ifdef TYPE_CHECKING 
1450  int args,req_min,req_max;
1451  if (item_type(sym)!=L_SYMBOL)
1452  {
1453    lprint(sym);
1454    lbreak("EVAL : is not a function name (not symbol either)");
1455    exit(0);
1456  }
1457#endif
1458
1459  void *fun=(lisp_sys_function *)(((lisp_symbol *)sym)->function);
1460  p_ref ref2( fun  );
1461
1462  // make sure the arguments given to the function are the correct number
1463  ltype t=item_type(fun);
1464
1465#ifdef TYPE_CHECKING
1466  switch (t)
1467  {
1468    case L_SYS_FUNCTION :
1469    case L_C_FUNCTION :
1470    case L_C_BOOL :
1471    case L_L_FUNCTION :   
1472    {
1473      req_min=((lisp_sys_function *)fun)->min_args;
1474      req_max=((lisp_sys_function *)fun)->max_args;
1475    } break;
1476    case L_USER_FUNCTION :
1477    {
1478      return eval_user_fun(sym,arg_list);
1479    } break;
1480    default :
1481    {
1482      lprint(sym);
1483      lbreak(" is not a function name");
1484      exit(0); 
1485    } break;
1486  }
1487
1488  if (req_min!=-1)
1489  {
1490    void *a=arg_list;
1491    for (args=0;a;a=CDR(a)) args++;    // count number of paramaters
1492
1493    if (args<req_min)
1494    {
1495      lprint(arg_list);
1496      lprint(sym->name);
1497      lbreak("\nToo few parameters to function\n");
1498      exit(0);
1499    } else if (req_max!=-1 && args>req_max)
1500    {
1501      lprint(arg_list);
1502      lprint(sym->name);
1503      lbreak("\nToo many parameters to function\n");
1504      exit(0);
1505    }
1506  }
1507#endif
1508
1509#ifdef L_PROFILE
1510  time_marker start;
1511#endif 
1512
1513
1514  p_ref ref1(arg_list);
1515  void *ret=NULL;
1516
1517  switch (t)
1518  {
1519    case L_SYS_FUNCTION :
1520    { ret=eval_sys_function( ((lisp_sys_function *)fun),arg_list); } break;   
1521    case L_L_FUNCTION :
1522    { ret=l_caller( ((lisp_sys_function *)fun)->fun_number,arg_list); } break;
1523    case L_USER_FUNCTION :
1524    {
1525      return eval_user_fun(sym,arg_list);
1526    } break;
1527    case L_C_FUNCTION :
1528    {
1529      void *first=NULL,*cur=NULL;
1530      p_ref r1(first),r2(cur);
1531      while (arg_list)
1532      {
1533                                if (first)
1534                                  cur=((cons_cell *)cur)->cdr=new_cons_cell();
1535                                else
1536                                  cur=first=new_cons_cell();
1537                       
1538                                void *val=eval(CAR(arg_list));
1539                                ((cons_cell *)cur)->car=val;
1540                                arg_list=lcdr(arg_list);
1541      }       
1542      ret=new_lisp_number(c_caller( ((lisp_sys_function *)fun)->fun_number,first));
1543    } break;
1544    case L_C_BOOL :
1545    {
1546      void *first=NULL,*cur=NULL;
1547      p_ref r1(first),r2(cur);
1548      while (arg_list)
1549      {
1550                                if (first)
1551                                  cur=((cons_cell *)cur)->cdr=new_cons_cell();
1552                                else
1553                                  cur=first=new_cons_cell();
1554                       
1555                                void *val=eval(CAR(arg_list));
1556                                ((cons_cell *)cur)->car=val;
1557                                arg_list=lcdr(arg_list);
1558      }       
1559
1560      if (c_caller( ((lisp_sys_function *)fun)->fun_number,first))
1561        ret=true_symbol;
1562      else ret=NULL;
1563    } break;
1564    default :
1565      fprintf(stderr,"not a fun, sholdn't happed\n");
1566  }
1567
1568#ifdef L_PROFILE
1569  time_marker end;
1570  ((lisp_symbol *)sym)->time_taken+=end.diff_time(&start);
1571#endif 
1572
1573
1574  return ret;
1575}         
1576
1577#ifdef L_PROFILE
1578void pro_print(bFILE *out, lisp_symbol *p)
1579{
1580  if (p)
1581  {
1582    pro_print(out,p->right);
1583    {
1584      char st[100];
1585      sprintf(st,"%20s %f\n",lstring_value(symbol_name(p)),((lisp_symbol *)p)->time_taken);
1586      out->write(st,strlen(st));
1587    }
1588    pro_print(out,p->left);
1589  }
1590}
1591
1592void preport(char *fn)
1593{
1594  bFILE *fp=open_file("preport.out","wb");
1595  pro_print(fp,lsym_root);
1596  delete fp;
1597}
1598#endif
1599
1600void *mapcar(void *arg_list)
1601{
1602  p_ref ref1(arg_list);
1603  void *sym=eval(CAR(arg_list));
1604  switch ((short)item_type(sym))
1605  {
1606    case L_SYS_FUNCTION :
1607    case L_USER_FUNCTION :
1608    case L_SYMBOL :
1609    break;
1610    default :
1611    {
1612      lprint(sym);
1613      lbreak(" is not a function\n");
1614      exit(0);
1615    }
1616  }
1617  int num_args=list_length(CDR(arg_list)),i,stop=0;
1618  if (!num_args) return 0;
1619
1620  void **arg_on=(void **)jmalloc(sizeof(void *)*num_args,"mapcar tmp array");
1621  cons_cell *list_on=(cons_cell *)CDR(arg_list);
1622  long old_ptr_son=l_ptr_stack.son;
1623
1624  for (i=0;i<num_args;i++)
1625  {
1626    arg_on[i]=(cons_cell *)eval(CAR(list_on));
1627    l_ptr_stack.push(&arg_on[i]);
1628
1629    list_on=(cons_cell *)CDR(list_on);
1630    if (!arg_on[i]) stop=1;
1631  }
1632 
1633  if (stop)
1634  {
1635    jfree(arg_on);
1636    return NULL;
1637  }
1638
1639  cons_cell *na_list=NULL,*return_list=NULL,*last_return=NULL;
1640
1641  do
1642  {
1643    na_list=NULL;          // create a cons list with all of the parameters for the function
1644
1645    cons_cell *first=NULL;                       // save the start of the list
1646    for (i=0;!stop &&i<num_args;i++)
1647    {
1648      if (!na_list)
1649        first=na_list=new_cons_cell();
1650      else
1651      {
1652        na_list->cdr=new_cons_cell();
1653                                na_list=(cons_cell *)CDR(na_list);
1654      }
1655
1656     
1657      if (arg_on[i])
1658      {
1659                                na_list->car=CAR(arg_on[i]);
1660                                arg_on[i]=(cons_cell *)CDR(arg_on[i]);
1661      }
1662      else stop=1;       
1663    }
1664    if (!stop)
1665    {
1666      cons_cell *c=new_cons_cell();
1667      c->car=eval_function((lisp_symbol *)sym,first);
1668      if (return_list)
1669        last_return->cdr=c;
1670      else
1671        return_list=c;
1672      last_return=c;
1673    }
1674  }
1675  while (!stop);
1676  l_ptr_stack.son=old_ptr_son;
1677
1678  jfree(arg_on);
1679  return return_list;
1680}
1681
1682void *concatenate(void *prog_list)
1683{
1684  void *el_list=CDR(prog_list);
1685  p_ref ref1(prog_list),ref2(el_list);
1686  void *ret=NULL;
1687  void *rtype=eval(CAR(prog_list));
1688
1689  long len=0;                                // determin the length of the resulting string
1690  if (rtype==string_symbol)
1691  {
1692    int elements=list_length(el_list);       // see how many things we need to concat
1693    if (!elements) ret=new_lisp_string("");
1694    else
1695    {
1696      void **str_eval=(void **)jmalloc(elements*sizeof(void *),"tmp eval array");
1697      int i,old_ptr_stack_start=l_ptr_stack.son;
1698
1699      // evalaute all the strings and count their lengths
1700      for (i=0;i<elements;i++,el_list=CDR(el_list))
1701      {
1702        str_eval[i]=eval(CAR(el_list));
1703        l_ptr_stack.push(&str_eval[i]);
1704
1705        switch ((short)item_type(str_eval[i]))
1706        {
1707          case L_CONS_CELL :
1708          {
1709            cons_cell *char_list=(cons_cell *)str_eval[i];
1710            while (char_list)
1711            {
1712              if (item_type(CAR(char_list))==(ltype)L_CHARACTER)
1713                len++;
1714              else
1715              {
1716                lprint(str_eval[i]);
1717                lbreak(" is not a character\n");               
1718                exit(0);
1719              }
1720              char_list=(cons_cell *)CDR(char_list);
1721            }
1722          } break;
1723          case L_STRING : len+=strlen(lstring_value(str_eval[i])); break;
1724          default :
1725            lprint(prog_list);
1726            lbreak("type not supported\n");
1727            exit(0);
1728          break;
1729
1730        }
1731      }
1732      lisp_string *st=new_lisp_string(len+1);
1733      char *s=lstring_value(st);
1734
1735      // now add the string up into the new string
1736      for (i=0;i<elements;i++)
1737      {
1738        switch ((short)item_type(str_eval[i]))
1739        {
1740          case L_CONS_CELL :
1741          {
1742            cons_cell *char_list=(cons_cell *)str_eval[i];
1743            while (char_list)
1744            {
1745              if (item_type(CAR(char_list))==L_CHARACTER)
1746                *(s++)=((lisp_character *)CAR(char_list))->ch;
1747              char_list=(cons_cell *)CDR(char_list);
1748            }
1749          } break;
1750          case L_STRING :
1751          {
1752            memcpy(s,lstring_value(str_eval[i]),strlen(lstring_value(str_eval[i])));
1753            s+=strlen(lstring_value(str_eval[i]));
1754          } break;
1755          default : ;     // already checked for, but make compiler happy
1756        }
1757      }
1758      jfree(str_eval);
1759      l_ptr_stack.son=old_ptr_stack_start;   // restore pointer GC stack
1760      *s=0;     
1761      ret=st;
1762    }
1763  }
1764  else
1765  {
1766    lprint(prog_list);
1767    lbreak("concat operation not supported, try 'string\n");
1768    exit(0);
1769  }
1770  return ret;
1771}
1772
1773
1774void *backquote_eval(void *args)
1775{
1776  if (item_type(args)!=L_CONS_CELL)
1777    return args;
1778  else if (args==NULL)
1779    return NULL;
1780  else if ((lisp_symbol *) (((cons_cell *)args)->car)==comma_symbol)
1781    return eval(CAR(CDR(args)));
1782  else
1783  {
1784    void *first=NULL,*last=NULL,*cur=NULL;
1785    p_ref ref1(first),ref2(last),ref3(cur),ref4(args);
1786    while (args)
1787    {
1788      if (item_type(args)==L_CONS_CELL)
1789      {
1790        if (CAR(args)==comma_symbol)               // dot list with a comma?
1791        {
1792          ((cons_cell *)last)->cdr=eval(CAR(CDR(args)));
1793          args=NULL;
1794        }
1795        else
1796        {
1797          cur=new_cons_cell();
1798          if (first)
1799            ((cons_cell *)last)->cdr=cur;
1800          else
1801            first=cur;
1802          last=cur;
1803          ((cons_cell *)cur)->car=backquote_eval(CAR(args));
1804          args=CDR(args);
1805        }
1806      } else
1807      {
1808        ((cons_cell *)last)->cdr=backquote_eval(args);
1809        args=NULL;
1810      }
1811
1812    }
1813    return (void *)first;
1814  }
1815  return NULL;       // for stupid compiler messages
1816}
1817
1818
1819void *eval_sys_function(lisp_sys_function *fun, void *arg_list)
1820{
1821  p_ref ref1(arg_list);
1822  void *ret=NULL;
1823  switch (fun->fun_number)
1824  {
1825    case 0 :                                                    // print
1826    {
1827      ret=NULL;
1828      while (arg_list)
1829      {
1830        ret=eval(CAR(arg_list));  arg_list=CDR(arg_list);
1831        lprint(ret);
1832      }
1833      return ret;
1834    } break;
1835    case 1 :                                                    // car
1836    { ret=lcar(eval(CAR(arg_list))); } break;
1837    case 2 :                                                    // cdr
1838    { ret=lcdr(eval(CAR(arg_list))); } break;
1839    case 3 :                                                    // length
1840    {
1841      void *v=eval(CAR(arg_list));
1842      switch (item_type(v))
1843      {
1844        case L_STRING : ret=new_lisp_number(strlen(lstring_value(v))); break;
1845        case L_CONS_CELL : ret=new_lisp_number(list_length(v)); break;
1846        default :
1847        { lprint(v);
1848          lbreak("length : type not supported\n");
1849        }
1850      }
1851    } break;                                           
1852    case 4 :                                                    // list
1853    {
1854      void *cur=NULL,*last=NULL,*first=NULL;
1855      p_ref r1(cur),r2(first),r3(last);
1856      while (arg_list)
1857      {
1858        cur=new_cons_cell();
1859        void *val=eval(CAR(arg_list));
1860        ((cons_cell *) cur)->car=val;
1861        if (last)
1862          ((cons_cell *)last)->cdr=cur;
1863        else first=cur;
1864        last=cur;
1865        arg_list=(cons_cell *)CDR(arg_list);
1866      }   
1867      ret=first;
1868    } break;
1869    case 5 :                                             // cons
1870    { void *c=new_cons_cell();
1871      p_ref r1(c);
1872      void *val=eval(CAR(arg_list));
1873      ((cons_cell *)c)->car=val;
1874      val=eval(CAR(CDR(arg_list)));
1875      ((cons_cell *)c)->cdr=val;
1876      ret=c;
1877    } break;
1878    case 6 :                                             // quote
1879    ret=CAR(arg_list);
1880    break;
1881    case 7 :                                             // eq
1882    {
1883      l_user_stack.push(eval(CAR(arg_list)));
1884      l_user_stack.push(eval(CAR(CDR(arg_list))));
1885      ret=lisp_eq(l_user_stack.pop(1),l_user_stack.pop(1));
1886    } break;
1887    case 24 :                                             // equal
1888    {
1889      l_user_stack.push(eval(CAR(arg_list)));
1890      l_user_stack.push(eval(CAR(CDR(arg_list))));
1891      ret=lisp_equal(l_user_stack.pop(1),l_user_stack.pop(1));
1892    } break;
1893    case 8 :                                           // +
1894    {
1895      long sum=0;
1896      while (arg_list)
1897      {
1898        sum+=lnumber_value(eval(CAR(arg_list)));
1899        arg_list=CDR(arg_list);
1900      }
1901      ret=new_lisp_number(sum);
1902    }
1903    break;
1904    case 28 :                                          // *
1905    {
1906      long sum;
1907      void *first=eval(CAR(arg_list));
1908      p_ref r1(first);
1909      if (arg_list && item_type(first)==L_FIXED_POINT)
1910      {
1911        sum=1<<16;
1912        do
1913        {
1914          sum=(sum>>8)*(lfixed_point_value(first)>>8);
1915          arg_list=CDR(arg_list);
1916          if (arg_list) first=eval(CAR(arg_list));
1917        } while (arg_list);
1918
1919        ret=new_lisp_fixed_point(sum);
1920      } else
1921      { sum=1;
1922        do
1923        {
1924          sum*=lnumber_value(eval(CAR(arg_list)));
1925          arg_list=CDR(arg_list);
1926          if (arg_list) first=eval(CAR(arg_list));
1927        } while (arg_list);
1928        ret=new_lisp_number(sum);
1929      }
1930    }
1931    break;
1932    case 29 :                                           // /
1933    {
1934      long sum=0,first=1;
1935      while (arg_list)
1936      {
1937        void *i=eval(CAR(arg_list));
1938        p_ref r1(i);
1939        if (item_type(i)!=L_NUMBER)
1940        {
1941          lprint(i);
1942          lbreak("/ only defined for numbers, cannot divide ");
1943          exit(0);
1944        } else if (first)
1945        {
1946          sum=((lisp_number *)i)->num;
1947          first=0;
1948        }
1949        else sum/=((lisp_number *)i)->num;
1950        arg_list=CDR(arg_list);
1951      }
1952      ret=new_lisp_number(sum);
1953    }
1954    break;
1955    case 9 :                                           // -
1956    {
1957      long x=lnumber_value(eval(CAR(arg_list)));         arg_list=CDR(arg_list);
1958      while (arg_list)
1959      {
1960        x-=lnumber_value(eval(CAR(arg_list)));
1961        arg_list=CDR(arg_list);
1962      }
1963      ret=new_lisp_number(x);
1964    }
1965    break;
1966    case 10 :                                         // if
1967    {
1968      if (eval(CAR(arg_list)))
1969      ret=eval(CAR(CDR(arg_list)));
1970      else
1971      { arg_list=CDR(CDR(arg_list));                 // check for a else part
1972        if (arg_list)   
1973          ret=eval(CAR(arg_list));
1974        else ret=NULL;
1975      }
1976    } break;
1977    case 63 :
1978    case 11 :                                         // setf
1979    {     
1980      void *set_to=eval(CAR(CDR(arg_list))),*i=NULL;
1981      p_ref r1(set_to),r2(i);
1982      i=CAR(arg_list);
1983
1984      ltype x=item_type(set_to);
1985      switch (item_type(i))
1986      {
1987        case L_SYMBOL :
1988        {
1989          switch (item_type (((lisp_symbol *)i)->value))
1990          {
1991            case L_NUMBER :
1992            {
1993              if (x==L_NUMBER && ((lisp_symbol *)i)->value!=l_undefined)
1994              ((lisp_number *)(((lisp_symbol *)i)->value))->num=lnumber_value(set_to);
1995              else
1996              ((lisp_symbol *)i)->value=set_to;
1997            } break;
1998            case L_OBJECT_VAR :
1999            {
2000              l_obj_set(((lisp_object_var *)(((lisp_symbol *)i)->value))->number,set_to); 
2001            } break;
2002            default :
2003            ((lisp_symbol *)i)->value=set_to;
2004          }
2005          ret=((lisp_symbol *)i)->value;
2006        } break;
2007        case L_CONS_CELL :   // this better be an 'aref'
2008        {
2009#ifdef TYPE_CHECKING
2010          void *car=((cons_cell *)i)->car;
2011          if (car==car_symbol)
2012          {
2013            car=eval(CAR(CDR(i)));
2014            if (!car || item_type(car)!=L_CONS_CELL)
2015            { lprint(car); lbreak("setq car : evaled object is not a cons cell\n"); exit(0); }
2016            ((cons_cell *)car)->car=set_to;
2017          } else if (car==cdr_symbol)
2018          {
2019            car=eval(CAR(CDR(i)));
2020            if (!car || item_type(car)!=L_CONS_CELL)
2021            { lprint(car); lbreak("setq cdr : evaled object is not a cons cell\n"); exit(0); }
2022            ((cons_cell *)car)->cdr=set_to;
2023          } else if (car==aref_symbol)
2024          {
2025#endif
2026            void *a=(lisp_1d_array *)eval(CAR(CDR(i)));
2027            p_ref r1(a);
2028#ifdef TYPE_CHECKING
2029            if (item_type(a)!=L_1D_ARRAY)
2030            {
2031              lprint(a);
2032              lbreak("is not an array (aref)\n");
2033              exit(0);
2034            }
2035#endif
2036            long num=lnumber_value(eval(CAR(CDR(CDR(i)))));
2037#ifdef TYPE_CHECKING
2038            if (num>=((lisp_1d_array *)a)->size || num<0)
2039            {
2040              lbreak("aref : value of bounds (%d)\n",num);
2041              exit(0);
2042            }
2043#endif
2044            void **data=(void **)(((lisp_1d_array *)a)+1);
2045            data[num]=set_to;
2046#ifdef TYPE_CHECKING
2047          } else
2048          {
2049            lbreak("expected (aref, car, cdr, or symbol) in setq\n");
2050            exit(0);
2051          }
2052#endif
2053          ret=set_to;
2054        } break;
2055
2056        default :
2057        {
2058          lprint(i);
2059          lbreak("setq/setf only defined for symbols and arrays now..\n");
2060          exit(0);
2061        }
2062      }
2063    } break;
2064    case 12 :                                      // symbol-list
2065      ret=NULL;
2066    break;
2067    case 13 :                                      // assoc
2068    {
2069      void *item=eval(CAR(arg_list));
2070      p_ref r1(item);
2071      void *list=(cons_cell *)eval(CAR(CDR(arg_list)));
2072      p_ref r2(list);
2073      ret=assoc(item,(cons_cell *)list);
2074    } break;
2075    case 20 :                                       // not is the same as null
2076    case 14 :                                       // null
2077    if (eval(CAR(arg_list))==NULL) ret=true_symbol; else ret=NULL;
2078    break;
2079    case 15 :                                       // acons
2080    {
2081      void *i1=eval(CAR(arg_list)),*i2=eval(CAR(CDR(arg_list)));
2082      p_ref r1(i1);
2083      cons_cell *cs=new_cons_cell();
2084      cs->car=i1;
2085      cs->cdr=i2;
2086      ret=cs;
2087    } break;
2088
2089    case 16 :                                       // pairlis
2090    {     
2091      l_user_stack.push(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2092      l_user_stack.push(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2093      void *n3=eval(CAR(arg_list));
2094      void *n2=l_user_stack.pop(1);
2095      void *n1=l_user_stack.pop(1);     
2096      ret=pairlis(n1,n2,n3);
2097    } break;
2098    case 17 :                                      // let
2099    {
2100      // make an a-list of new variable names and new values
2101      void *var_list=CAR(arg_list),
2102           *block_list=CDR(arg_list);
2103      p_ref r1(block_list),r2(var_list);
2104      long stack_start=l_user_stack.son;
2105
2106      while (var_list)
2107      {
2108        void *var_name=CAR(CAR(var_list));
2109#ifdef TYPE_CHECKING
2110        if (item_type(var_name)!=L_SYMBOL)
2111        {
2112          lprint(var_name);
2113          lbreak("should be a symbol (let)\n");
2114          exit(0);
2115        }
2116#endif
2117
2118        l_user_stack.push(((lisp_symbol *)var_name)->value);
2119        ((lisp_symbol *)var_name)->value=eval(CAR(CDR(CAR(var_list))));
2120        var_list=CDR(var_list);
2121      }
2122
2123      // now evaluate each of the blocks with the new enviroment and return value
2124      // from the last block
2125      while (block_list)
2126      {   
2127        ret=eval(CAR(block_list));
2128        block_list=CDR(block_list);         
2129      }
2130
2131      long cur_stack=stack_start;
2132      var_list=CAR(arg_list);      // now restore the old symbol values
2133      while (var_list)
2134      {
2135        void *var_name=CAR(CAR(var_list));
2136        ((lisp_symbol *)var_name)->value=l_user_stack.sdata[cur_stack++];
2137        var_list=CDR(var_list);
2138      }
2139      l_user_stack.son=stack_start;     // restore the stack
2140    }
2141    break;       
2142    case 18 :                                   // defun
2143    {
2144      void *symbol=CAR(arg_list);
2145#ifdef TYPE_CHECKING
2146      if (item_type(symbol)!=L_SYMBOL)
2147      {
2148        lprint(symbol);
2149        lbreak(" is not a symbol! (DEFUN)\n");
2150        exit(0);
2151      }
2152
2153      if (item_type(arg_list)!=L_CONS_CELL)
2154      {
2155        lprint(arg_list);
2156        lbreak("is not a lambda list (DEFUN)\n");
2157        exit(0);
2158      }
2159#endif
2160      void *block_list=CDR(CDR(arg_list));
2161
2162#ifndef NO_LIBS
2163      long a=cash.reg_lisp_block(lcar(lcdr(arg_list)));
2164      long b=cash.reg_lisp_block(block_list);
2165      lisp_user_function *ufun=new_lisp_user_function(a,b);
2166#else
2167      lisp_user_function *ufun=new_lisp_user_function(lcar(lcdr(arg_list)),block_list);
2168#endif
2169      set_symbol_function(symbol,ufun);
2170      ret=symbol;
2171    } break;
2172    case 19 :                                       // atom
2173    { ret=lisp_atom(eval(CAR(arg_list))); }
2174    case 21 :                                           // and
2175    {
2176      void *l=arg_list;
2177      p_ref r1(l);
2178      ret=true_symbol;
2179      while (l)
2180      {
2181        if (!eval(CAR(l)))
2182        {
2183          ret=NULL;
2184          l=NULL;             // short-circuit
2185        } else l=CDR(l);
2186      }
2187    } break;
2188    case 22 :                                           // or
2189    {
2190      void *l=arg_list;
2191      p_ref r1(l);
2192      ret=NULL;
2193      while (l)
2194      {
2195        if (eval(CAR(l)))
2196        {
2197          ret=true_symbol;
2198          l=NULL;            // short circuit
2199        } else l=CDR(l);
2200      }
2201    } break;
2202    case 23 :                                          // progn
2203    { ret=eval_block(arg_list); } break;
2204    case 25 :                                        // concatenate
2205      ret=concatenate(arg_list);
2206    break;
2207    case 26 :                                        // char-code
2208    {
2209      void *i=eval(CAR(arg_list));   
2210      p_ref r1(i);
2211      ret=NULL;
2212      switch (item_type(i))
2213      {
2214        case L_CHARACTER :
2215        { ret=new_lisp_number(((lisp_character *)i)->ch); } break;
2216        case L_STRING :
2217        {  ret=new_lisp_number(*lstring_value(i)); } break;
2218        default :
2219        {
2220          lprint(i);
2221          lbreak(" is not character type\n");
2222          exit(0);
2223        }
2224      }             
2225    } break;
2226    case 27 :                                        // code-char
2227    {
2228      void *i=eval(CAR(arg_list));
2229      p_ref r1(i);
2230      if (item_type(i)!=L_NUMBER)
2231      {
2232        lprint(i);
2233        lbreak(" is not number type\n");
2234        exit(0);
2235      }
2236      ret=new_lisp_character(((lisp_number *)i)->num);
2237    } break;
2238    case 30 :                                       // cond
2239    {
2240      void *block_list=CAR(arg_list);
2241      p_ref r1(block_list);
2242      if (!block_list) ret=NULL;
2243      else
2244      {
2245        ret=NULL;
2246        while (block_list)
2247        {
2248          if (eval(lcar(CAR(block_list))))
2249            ret=eval(CAR(CDR(CAR(block_list))));
2250          block_list=CDR(block_list);
2251        }
2252      }
2253    } break;
2254    case 31 :                                       // select
2255    {
2256      void *selector=eval(CAR(arg_list));
2257      void *sel=CDR(arg_list);
2258      p_ref r1(selector),r2(sel);
2259      while (sel)
2260      {
2261        if (lisp_equal(selector,eval(CAR(CAR(sel)))))
2262        {
2263          sel=CDR(CAR(sel));
2264          while (sel)
2265          {
2266            ret=eval(CAR(sel));
2267            sel=CDR(sel);
2268          }
2269          sel=NULL;
2270        } else sel=CDR(sel);
2271      }
2272    } break;
2273    case 32 :                                      // function   
2274      ret=lookup_symbol_function(eval(CAR(arg_list)));
2275    break;
2276    case 33 :                                      // mapcar
2277      ret=mapcar(arg_list);   
2278    case 34 :                                      // funcall
2279    {
2280      void *n1=eval(CAR(arg_list));
2281      ret=eval_function((lisp_symbol *)n1,CDR(arg_list));     
2282    } break;
2283    case 35 :                                                   // >
2284    {
2285      long n1=lnumber_value(eval(CAR(arg_list)));
2286      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
2287      if (n1>n2) ret=true_symbol; else ret=NULL;
2288    }
2289    break;     
2290    case 36 :                                                   // <
2291    {
2292      long n1=lnumber_value(eval(CAR(arg_list)));
2293      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
2294      if (n1<n2) ret=true_symbol; else ret=NULL;
2295    }   
2296    break;
2297    case 47 :                                                   // >=
2298    {
2299      long n1=lnumber_value(eval(CAR(arg_list)));
2300      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
2301      if (n1>=n2) ret=true_symbol; else ret=NULL;
2302    }
2303    break;     
2304    case 48 :                                                   // <=
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
2312    case 37 :                                                  // tmp-space
2313      tmp_space();
2314      ret=true_symbol;
2315    break;
2316    case 38 :                                                  // perm-space
2317      perm_space();
2318      ret=true_symbol;
2319    break;
2320    case 39 :
2321      void *symb;
2322      symb=eval(CAR(arg_list));
2323#ifdef TYPE_CHECKING
2324      if (item_type(symb)!=L_SYMBOL)
2325      {
2326        lprint(symb);
2327        lbreak(" is not a symbol (symbol-name)\n");
2328        exit(0);
2329      }
2330#endif
2331      ret=((lisp_symbol *)symb)->name;   
2332    break;
2333    case 40 :                                                  // trace
2334      trace_level++;
2335      if (arg_list)
2336        trace_print_level=lnumber_value(eval(CAR(arg_list)));
2337      ret=true_symbol;
2338    break;
2339    case 41 :                                                  // untrace
2340      if (trace_level>0)
2341      {
2342                                trace_level--;
2343                                ret=true_symbol;
2344      } else ret=NULL;
2345    break;
2346    case 42 :                                                 // digitstr
2347    {
2348      char tmp[50],*tp;
2349      long num=lnumber_value(eval(CAR(arg_list)));
2350      long dig=lnumber_value(eval(CAR(CDR(arg_list))));
2351      tp=tmp+49;
2352      *(tp--)=0;
2353      for (;num;)
2354      {
2355                                int d;
2356                                d=num%10;
2357                                *(tp--)=d+'0';
2358                                num/=10;
2359                                dig--;
2360      }
2361      while (dig--)
2362        *(tp--)='0';
2363      ret=new_lisp_string(tp+1);
2364    } break;
2365    case 98:
2366    case 66:
2367    case 43:                                     // compile-file
2368    {
2369                        void *fn = eval( CAR( arg_list ) );
2370                        char *st = lstring_value( fn );
2371                        p_ref r1( fn );
2372                        bFILE *fp;
2373                        if( fun->fun_number == 98 )          // local_load
2374                        {
2375                                // A special test for gamma.lsp
2376                                if( strcmp( st, "gamma.lsp" ) == 0 )
2377                                {
2378                                        char *gammapath;
2379                                        gammapath = (char *)jmalloc( strlen( get_save_filename_prefix() ) + 10, "gammapath" );
2380                                        sprintf( gammapath, "%sgamma.lsp\0", get_save_filename_prefix() );
2381                                        fp = new jFILE( gammapath, "rb" );
2382                                        jfree( gammapath );
2383                                }
2384                                else
2385                                {
2386                                        fp = new jFILE( st, "rb" );
2387                                }
2388                        }
2389                        else
2390                        {
2391                                fp = open_file(st,"rb");
2392                        }
2393
2394                        if( fp->open_failure() )
2395                        {
2396                                delete fp;
2397                                if( DEFINEDP(symbol_value(load_warning)) && symbol_value(load_warning) )
2398                                        dprintf("Warning : file %s does not exists\n",st);
2399                                ret = NULL;
2400                        }
2401                        else
2402                        {
2403                                long l=fp->file_size();
2404                                char *s=(char *)jmalloc(l+1,"loaded script");
2405                                if (!s)
2406                                {
2407                                  printf("Malloc error in load_script\n");
2408                                  exit(0);
2409                                }
2410                       
2411                                fp->read(s,l);
2412                                s[l]=0;
2413                                delete fp;
2414                                char *cs=s;
2415                        #ifndef NO_LIBS
2416                                char msg[100];
2417                                sprintf(msg,"(load \"%s\")",st);
2418                                if (stat_man) stat_man->push(msg,NULL);
2419                                crc_man.get_filenumber(st);               // make sure this file gets crc'ed
2420                        #endif
2421                                void *compiled_form=NULL;
2422                                p_ref r11(compiled_form);
2423                                while (!end_of_program(cs))  // see if there is anything left to compile and run
2424                                {
2425                        #ifndef NO_LIBS
2426                                  if (stat_man) stat_man->update((cs-s)*100/l);
2427                        #endif
2428                                  void *m=mark_heap(TMP_SPACE);
2429                                  compiled_form=compile(cs);
2430                                  eval(compiled_form);
2431                                  compiled_form=NULL;
2432                                  restore_heap(m,TMP_SPACE);
2433                                }       
2434                        #ifndef NO_LIBS
2435                                if (stat_man) stat_man->update(100);
2436                                if (stat_man) stat_man->pop();
2437                        #endif     
2438                                jfree(s);
2439                                ret=fn;
2440      }
2441    } break;
2442    case 44 :                                                 // abs
2443      ret=new_lisp_number(abs(lnumber_value(eval(CAR(arg_list))))); break;
2444    case 45 :                                                 // min
2445    {
2446      int x=lnumber_value(eval(CAR(arg_list))),y=lnumber_value(eval(CAR(CDR(arg_list))));
2447      if (x<y) ret=new_lisp_number(x); else ret=new_lisp_number(y);
2448    } break;
2449    case 46 :                                                 // max
2450    {
2451      int x=lnumber_value(eval(CAR(arg_list))),y=lnumber_value(eval(CAR(CDR(arg_list))));
2452      if (x>y) ret=new_lisp_number(x); else ret=new_lisp_number(y);
2453    } break;
2454    case 49 :                        // backquote
2455    {
2456      ret=backquote_eval(CAR(arg_list));
2457    } break;
2458    case 50 :
2459    {
2460      lprint(arg_list);
2461      lbreak("comma is illegal outside of backquote\n");
2462      exit(0);
2463      ret=NULL;
2464    } break;
2465    case 51 :
2466    {
2467      long x=lnumber_value(eval(CAR(arg_list)));
2468      ret=nth(x,eval(CAR(CDR(arg_list))));
2469    } break;
2470    case 52 : resize_tmp(lnumber_value(eval(CAR(arg_list)))); break;
2471    case 53 : resize_perm(lnumber_value(eval(CAR(arg_list)))); break;   
2472    case 54 : ret=new_lisp_fixed_point(lisp_cos(lnumber_value(eval(CAR(arg_list))))); break;
2473    case 55 : ret=new_lisp_fixed_point(lisp_sin(lnumber_value(eval(CAR(arg_list))))); break;
2474    case 56 :
2475    {
2476      long y=(lnumber_value(eval(CAR(arg_list))));   arg_list=CDR(arg_list);
2477      long x=(lnumber_value(eval(CAR(arg_list))));
2478      ret=new_lisp_number(lisp_atan2(y,x));     
2479    } break;
2480    case 57 :
2481    {
2482      int sp=current_space;
2483      current_space=PERM_SPACE;
2484      long x=0;
2485      while (arg_list)
2486      {
2487        void *sym=eval(CAR(arg_list));
2488        p_ref r1(sym);
2489        switch (item_type(sym))
2490        {
2491          case L_SYMBOL :
2492          { ((lisp_symbol *)sym)->value=new_lisp_number(x); } break;
2493          case L_CONS_CELL :
2494          {
2495            void *s=eval(CAR(sym));
2496            p_ref r1(s);
2497#ifdef TYPE_CHECKING
2498            if (item_type(s)!=L_SYMBOL)
2499            { lprint(arg_list);
2500              lbreak("expecting (sybmol value) for enum\n");
2501              exit(0);
2502            }
2503#endif
2504            x=lnumber_value(eval(CAR(CDR(sym))));
2505            ((lisp_symbol *)sym)->value=new_lisp_number(x);
2506          } break;
2507          default :
2508          {
2509            lprint(arg_list);
2510            lbreak("expecting symbol or (symbol value) in enum\n");
2511            exit(0);
2512          }
2513        }
2514        arg_list=CDR(arg_list);
2515        x++;
2516      }     
2517      current_space=sp;
2518    } break;
2519    case 58 :
2520    {
2521      exit(0);
2522    } break;
2523    case 59 :
2524    {
2525      ret=eval(eval(CAR(arg_list)));
2526    } break;
2527    case 60 : lbreak("User break"); break;
2528    case 61 :
2529    {
2530      long x=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2531      long y=lnumber_value(eval(CAR(arg_list)));
2532      if (y==0) { lbreak("mod : division by zero\n"); y=1; }     
2533      ret=new_lisp_number(x%y);
2534    } break;
2535/*    case 62 :
2536    {
2537      char *fn=lstring_value(eval(CAR(arg_list)));
2538      FILE *fp=fopen(fn,"wb");
2539      if (!fp)
2540        lbreak("could not open %s for writing",fn);
2541      else
2542      {
2543        for (void *s=symbol_list;s;s=CDR(s))             
2544          fprintf(fp,"%8d  %s\n",((lisp_symbol *)(CAR(s)))->call_counter,
2545                  lstring_value(((lisp_symbol *)(CAR(s)))->name));
2546        fclose(fp);
2547      }
2548    } break;*/
2549    case 64 :
2550    {
2551      void *bind_var=CAR(arg_list); arg_list=CDR(arg_list);
2552      p_ref r1(bind_var);
2553      if (item_type(bind_var)!=L_SYMBOL)
2554      { lbreak("expecting for iterator to be a symbol\n"); exit(1); }
2555
2556      if (CAR(arg_list)!=in_symbol)
2557      { lbreak("expecting in after 'for iterator'\n"); exit(1); }
2558      arg_list=CDR(arg_list);
2559
2560      void *ilist=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2561      p_ref r2(ilist);
2562     
2563      if (CAR(arg_list)!=do_symbol)
2564      { lbreak("expecting do after 'for iterator in list'\n"); exit(1); }
2565      arg_list=CDR(arg_list);
2566
2567      void *block=NULL,*ret=NULL;
2568      p_ref r3(block);
2569      l_user_stack.push(symbol_value(bind_var));  // save old symbol value
2570      while (ilist)
2571      {
2572                                set_symbol_value(bind_var,CAR(ilist));
2573                                for (block=arg_list;block;block=CDR(block))
2574                                  ret=eval(CAR(block));
2575                                ilist=CDR(ilist);
2576      }
2577      set_symbol_value(bind_var,l_user_stack.pop(1));
2578      ret=ret;
2579    } break;
2580    case 65 :
2581    {
2582      bFILE *old_file=current_print_file;
2583      void *str1=eval(CAR(arg_list));
2584      p_ref r1(str1);
2585      void *str2=eval(CAR(CDR(arg_list)));
2586     
2587     
2588      current_print_file=open_file(lstring_value(str1),
2589                                   lstring_value(str2));
2590
2591      if (!current_print_file->open_failure())
2592      {
2593                                while (arg_list)
2594                                {
2595                                  ret=eval(CAR(arg_list));       
2596                                  arg_list=CDR(arg_list);
2597                                }
2598      }     
2599      delete current_print_file;
2600      current_print_file=old_file;     
2601
2602    } break;
2603    case 67 :
2604    {
2605      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2606      while (arg_list)
2607      {
2608        first&=lnumber_value(eval(CAR(arg_list)));
2609                                arg_list=CDR(arg_list);
2610      }
2611      ret=new_lisp_number(first);
2612    } break;
2613    case 68 :
2614    {
2615      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2616      while (arg_list)
2617      {
2618        first|=lnumber_value(eval(CAR(arg_list)));
2619                                arg_list=CDR(arg_list);
2620      }
2621      ret=new_lisp_number(first);
2622    } break;
2623    case 69 :
2624    {
2625      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2626      while (arg_list)
2627      {
2628        first^=lnumber_value(eval(CAR(arg_list)));
2629                                arg_list=CDR(arg_list);
2630      }
2631      ret=new_lisp_number(first);
2632    } break;
2633    case 70 :  // make-array
2634    {
2635      long l=lnumber_value(eval(CAR(arg_list)));
2636      if (l>=2<<16 || l<=0)
2637      {
2638                                lbreak("bad array size %d\n",l);
2639                                exit(0);
2640      }
2641      ret=new_lisp_1d_array(l,CDR(arg_list));
2642    } break;
2643    case 71 : // aref
2644    {
2645      long x=lnumber_value(eval(CAR(CDR(arg_list))));
2646      ret=lget_array_element(eval(CAR(arg_list)),x);
2647    } break;
2648    case 72 : // if-1progn
2649    {
2650      if (eval(CAR(arg_list)))
2651        ret=eval_block(CAR(CDR(arg_list)));
2652      else ret=eval(CAR(CDR(CDR(arg_list))));
2653
2654    } break;
2655    case 73 : // if-2progn
2656    {
2657      if (eval(CAR(arg_list)))
2658        ret=eval(CAR(CDR(arg_list)));
2659      else ret=eval_block(CAR(CDR(CDR(arg_list))));
2660
2661    } break;
2662    case 74 : // if-12progn
2663    {
2664      if (eval(CAR(arg_list)))
2665        ret=eval_block(CAR(CDR(arg_list)));
2666      else ret=eval_block(CAR(CDR(CDR(arg_list))));
2667
2668    } break;
2669    case 75 : // eq0
2670    {
2671      void *v=eval(CAR(arg_list));
2672      if (item_type(v)!=L_NUMBER || (((lisp_number *)v)->num!=0))
2673        ret=NULL;
2674      else ret=true_symbol;
2675    } break;
2676    case 76 : // preport
2677    {
2678#ifdef L_PROFILE
2679      char *s=lstring_value(eval(CAR(arg_list)));     
2680      preport(s);
2681#endif
2682    } break;
2683    case 77 : // search
2684    {
2685      void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2686      p_ref r1(arg1);       // protect this refrence
2687      char *haystack=lstring_value(eval(CAR(arg_list)));     
2688      char *needle=lstring_value(arg1);
2689
2690      char *find=strstr(haystack,needle);
2691      if (find)
2692        ret=new_lisp_number(find-haystack);
2693      else ret=NULL;
2694    } break;
2695    case 78 : // elt
2696    {
2697      void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2698      p_ref r1(arg1);       // protect this refrence
2699      long x=lnumber_value(eval(CAR(arg_list)));
2700      char *st=lstring_value(arg1);
2701      if (x < 0 || (unsigned)x >= strlen(st))
2702      { lbreak("elt : out of range of string\n"); ret=NULL; }
2703      else
2704        ret=new_lisp_character(st[x]);
2705    } break;
2706    case 79 : // listp
2707    {
2708      return item_type(eval(CAR(arg_list)))==L_CONS_CELL ? true_symbol : NULL;
2709    } break;
2710    case 80 : // numberp
2711    {
2712      int t=item_type(eval(CAR(arg_list)));
2713      if (t==L_NUMBER || t==L_FIXED_POINT) return true_symbol; else return NULL;
2714    } break;
2715    case 81 : // do
2716    {
2717      void *init_var=CAR(arg_list);
2718      p_ref r1(init_var);
2719      int i,ustack_start=l_user_stack.son;      // restore stack at end
2720      void *sym=NULL;
2721      p_ref r2(sym);
2722
2723      // check to make sure iter vars are symbol and push old values
2724      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
2725      {
2726                                sym=CAR(CAR(init_var));
2727                                if (item_type(sym)!=L_SYMBOL)
2728                                { lbreak("expecting symbol name for iteration var\n"); exit(0); }
2729                                l_user_stack.push(symbol_value(sym));
2730      }
2731     
2732      void **do_evaled=l_user_stack.sdata+l_user_stack.son;
2733      // push all of the init forms, so we can set the symbol
2734      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))   
2735                                l_user_stack.push(eval(CAR(CDR(CAR((init_var))))));
2736
2737      // now set all the symbols
2738      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)
2739      {
2740                                sym=CAR(CAR(init_var));
2741                                set_symbol_value(sym,*do_evaled);
2742      }
2743
2744      i=0;       // set i to 1 when terminate conditions are meet
2745      do
2746      {
2747                                i=(eval(CAR(CAR(CDR(arg_list))))!=NULL);
2748                                if (!i)
2749                                {
2750                                  eval_block(CDR(CDR(arg_list)));
2751                                  for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
2752                                    eval(CAR(CDR(CDR(CAR(init_var)))));
2753                                }
2754      } while (!i);
2755     
2756      ret=eval(CAR(CDR(CAR(CDR(arg_list)))));
2757
2758      // restore old values for symbols
2759      do_evaled=l_user_stack.sdata+ustack_start;
2760      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)     
2761      {
2762                                sym=CAR(CAR(init_var));
2763                                set_symbol_value(sym,*do_evaled);
2764      }
2765
2766      l_user_stack.son=ustack_start;
2767     
2768    } break;
2769    case 82 : // gc
2770    {
2771      collect_space(current_space);
2772    } break;
2773    case 83 : // schar
2774    {
2775      char *s=lstring_value(eval(CAR(arg_list)));      arg_list=CDR(arg_list);
2776      long x=lnumber_value(eval(CAR(arg_list)));
2777
2778      if ((unsigned)x >= strlen(s))
2779      { lbreak("SCHAR: index %d should be less than the length of the string\n",x); exit(0); }
2780      else if (x<0)
2781      { lbreak("SCHAR: index should not be negative\n"); exit(0); }
2782      return new_lisp_character(s[x]);
2783    } break;
2784    case 84 :// symbolp
2785    { if (item_type(eval(CAR(arg_list)))==L_SYMBOL) return true_symbol;
2786      else return NULL; } break;
2787    case 85 :  // num2str
2788    {
2789      char str[10];
2790      sprintf(str,"%ld",lnumber_value(eval(CAR(arg_list))));
2791      ret=new_lisp_string(str);
2792    } break;
2793    case 86 : // nconc
2794    {
2795      void *l1=eval(CAR(arg_list)); arg_list=CDR(arg_list);           
2796      p_ref r1(l1);     
2797      void *first=l1,*next;
2798      p_ref r2(first);
2799
2800      if (!l1)
2801      {
2802                                l1=first=eval(CAR(arg_list));
2803                                arg_list=CDR(arg_list);
2804      }
2805     
2806      if (item_type(l1)!=L_CONS_CELL)
2807      { lprint(l1); lbreak("first arg should be a list\n"); }
2808      do
2809      {
2810                                next=l1;
2811                                while (next) { l1=next; next=lcdr(next); }
2812                                ((cons_cell *)l1)->cdr=eval(CAR(arg_list));     
2813                                arg_list=CDR(arg_list);
2814      } while (arg_list);     
2815      ret=first;
2816    } break;
2817    case 87 : // first
2818    { ret=CAR(eval(CAR(arg_list))); } break;
2819    case 88 : // second
2820    { ret=CAR(CDR(eval(CAR(arg_list)))); } break;
2821    case 89 : // third
2822    { ret=CAR(CDR(CDR(eval(CAR(arg_list))))); } break;
2823    case 90 : // fourth
2824    { ret=CAR(CDR(CDR(CDR(eval(CAR(arg_list)))))); } break;
2825    case 91 : // fifth
2826    { ret=CAR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))); } break;
2827    case 92 : // sixth
2828    { ret=CAR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))); } break;
2829    case 93 : // seventh
2830    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))))); } break;
2831    case 94 : // eight
2832    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))))); } break;
2833    case 95 : // ninth
2834    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))))))); } break;
2835    case 96 : // tenth
2836    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))))))); } break;
2837    case 97 :
2838    {
2839      long x1=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2840      long x2=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2841      void *st=eval(CAR(arg_list));
2842      p_ref r1(st);
2843
2844      if (x1 < 0 || x1 > x2 || (unsigned)x2 >= strlen(lstring_value(st)))
2845        lbreak("substr : bad x1 or x2 value");
2846
2847      lisp_string *s=new_lisp_string(x2-x1+2);
2848      if (x2-x1)
2849        memcpy(lstring_value(s),lstring_value(st)+x1,x2-x1+1);
2850
2851      *(lstring_value(s)+(x2-x1+1))=0;
2852      ret=s;
2853    } break;
2854    case 99 :
2855    {
2856      void *r=NULL,*rstart=NULL;
2857      p_ref r1(r),r2(rstart);
2858      while (arg_list)
2859      {
2860                                void *q=eval(CAR(arg_list));
2861                                if (!rstart) rstart=q;
2862                                while (r && CDR(r)) r=CDR(r);
2863                                CDR(r)=q;         
2864                                arg_list=CDR(arg_list);
2865      }
2866      return rstart;
2867    } break;
2868
2869    default :
2870    { dprintf("Undefined system function number %d\n",((lisp_sys_function *)fun)->fun_number); }
2871  }
2872  return ret;
2873}
2874
2875void tmp_space()
2876{
2877  current_space=TMP_SPACE;
2878}
2879
2880void perm_space()
2881{
2882  current_space=PERM_SPACE;
2883}
2884
2885void use_user_space(void *addr, long size)
2886{
2887  current_space=2;
2888  free_space[USER_SPACE]=space[USER_SPACE]=(char *)addr;
2889  space_size[USER_SPACE]=size;
2890}
2891
2892
2893void *eval_user_fun(lisp_symbol *sym, void *arg_list)
2894{
2895  void *ret=NULL;
2896  p_ref ref1(ret);
2897
2898#ifdef TYPE_CHECKING
2899  if (item_type(sym)!=L_SYMBOL)
2900  {
2901    lprint(sym);
2902    lbreak("EVAL : is not a function name (not symbol either)");
2903    exit(0);
2904  }
2905#endif
2906#ifdef L_PROFILE
2907  time_marker start;
2908#endif 
2909
2910
2911  lisp_user_function *fun=(lisp_user_function *)(((lisp_symbol *)sym)->function);
2912
2913#ifdef TYPE_CHECKING
2914  if (item_type(fun)!=L_USER_FUNCTION)
2915  {
2916    lprint(sym);
2917    lbreak("is not a user defined function\n");
2918  }
2919#endif
2920
2921#ifndef NO_LIBS
2922  void *fun_arg_list=cash.lblock(fun->alist);
2923  void *block_list=cash.lblock(fun->blist);
2924  p_ref r9(block_list),r10(fun_arg_list);
2925#else
2926  void *fun_arg_list=fun->arg_list;
2927  void *block_list=fun->block_list;
2928  p_ref r9(block_list),r10(fun_arg_list);
2929#endif
2930
2931
2932
2933  // mark the start start, so we can restore when done
2934  long stack_start=l_user_stack.son; 
2935
2936  // first push all of the old symbol values
2937  void *f_arg=fun_arg_list;
2938  p_ref r18(f_arg);
2939  p_ref r19(arg_list);
2940  for (;f_arg;f_arg=CDR(f_arg))
2941  {
2942    l_user_stack.push(((lisp_symbol *)CAR(f_arg))->value);
2943  }
2944
2945  // open block so that local vars aren't saved on the stack
2946  {
2947    int new_start=l_user_stack.son;
2948    int i=new_start;
2949    // now push all the values we wish to gather
2950    for (f_arg=fun_arg_list;f_arg;)
2951    {
2952      if (!arg_list)
2953      { lprint(sym);  lbreak("too few parameter to function\n"); exit(0); }
2954      l_user_stack.push(eval(CAR(arg_list)));
2955      f_arg=CDR(f_arg);
2956      arg_list=CDR(arg_list);
2957    }
2958
2959
2960    // now store all the values and put them into the symbols
2961    for (f_arg=fun_arg_list;f_arg;f_arg=CDR(f_arg))
2962      ((lisp_symbol *)CAR(f_arg))->value=l_user_stack.sdata[i++];
2963
2964    l_user_stack.son=new_start;
2965  }
2966
2967
2968
2969  if (f_arg)
2970  { lprint(sym);  lbreak("too many parameter to function\n"); exit(0); }
2971
2972
2973  // now evaluate the function block
2974  while (block_list)
2975  {
2976    ret=eval(CAR(block_list));
2977    block_list=CDR(block_list);   
2978  }
2979
2980  long cur_stack=stack_start;
2981  for (f_arg=fun_arg_list;f_arg;f_arg=CDR(f_arg))
2982    ((lisp_symbol *)CAR(f_arg))->value=l_user_stack.sdata[cur_stack++];
2983
2984  l_user_stack.son=stack_start;
2985
2986#ifdef L_PROFILE
2987  time_marker end;
2988  ((lisp_symbol *)sym)->time_taken+=end.diff_time(&start);
2989#endif 
2990
2991
2992  return ret;
2993}
2994
2995
2996
2997
2998
2999void *eval(void *prog)
3000{
3001 
3002
3003  void *ret=NULL; 
3004  p_ref ref1(prog);
3005
3006
3007  int tstart=trace_level;
3008 
3009  if (trace_level)
3010  {
3011    if (trace_level<=trace_print_level)
3012    {
3013      dprintf("%d (%d,%d,%d) TRACE : ",trace_level,
3014              space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
3015              space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
3016              l_ptr_stack.son);
3017      lprint(prog);
3018
3019      dprintf("\n");
3020    }
3021    trace_level++;
3022  }
3023  if (prog)
3024  {
3025    switch (item_type(prog))
3026    {   
3027      case L_BAD_CELL :
3028      { lbreak("error : eval on a bad cell\n"); exit(0); } break;
3029      case L_CHARACTER :
3030      case L_STRING :
3031      case L_NUMBER :
3032      case L_POINTER :
3033      case L_FIXED_POINT :
3034      { ret=prog; } break;
3035      case L_SYMBOL :
3036      { if (prog==true_symbol)
3037                                ret=prog;
3038        else
3039                                {
3040                                  ret=lookup_symbol_value(prog);
3041                                  if (item_type(ret)==L_OBJECT_VAR)
3042                                    ret=l_obj_get(((lisp_object_var *)ret)->number);
3043                                }
3044      } break;
3045      case L_CONS_CELL :
3046      {
3047        ret=eval_function((lisp_symbol *)CAR(prog),CDR(prog));
3048      }
3049      break;
3050      default :
3051        fprintf(stderr,"shouldn't happen\n");
3052    }
3053  }
3054  if (tstart)
3055  {
3056    trace_level--;
3057    if (trace_level<=trace_print_level)
3058      dprintf("%d (%d,%d,%d) TRACE ==> ",trace_level,
3059              space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
3060              space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
3061              l_ptr_stack.son);
3062    lprint(ret);
3063    dprintf("\n");
3064  }
3065 
3066/*  l_user_stack.push(ret);
3067  collect_space(PERM_SPACE);
3068  ret=l_user_stack.pop(1);  */
3069
3070
3071  return ret;
3072}
3073
3074#define TOTAL_SYS_FUNCS 99
3075                                 //  0      1    2       3       4      5      6      7
3076char *sys_funcs[TOTAL_SYS_FUNCS]={"print","car","cdr","length","list","cons","quote","eq",
3077                                // 8   9   10    11       12          13     14      15      16
3078                                  "+","-","if","setf","symbol-list","assoc","null","acons","pairlis",
3079                                // 17     18     19     20     21     22    23      24
3080                                  "let","defun","atom","not", "and", "or","progn","equal",
3081                                // 25               26          27       28  29   30     31
3082                                  "concatenate","char-code","code-char","*","/","cond","select",
3083                                // 32            33         34     35    36    37       
3084                                  "function", "mapcar", "funcall", ">", "<", "tmp-space",
3085                                //   38              39        40       41         42
3086                                  "perm-space","symbol-name","trace","untrace","digstr",
3087                                //   43            44   45    46    47  48       49
3088                                  "compile-file","abs","min","max",">=","<=","backquote",
3089                                //  50      51      52         53           54    55     56
3090                                  "comma","nth","resize-tmp","resize-perm","cos","sin","atan2",
3091                                  // 57       58     59     60     61   62              63
3092                                  "enum", "quit","eval","break","mod","write_profile","setq",
3093                                  // 64    65          66      67       68        69        70
3094                                  "for", "open_file","load","bit-and","bit-or","bit-xor","make-array",
3095                                  // 71      72          73          74        75      76
3096                                  "aref","if-1progn","if-2progn","if-12progn","eq0","preport",
3097                                  // 77     78         79        80       81     82     83
3098                                  "search","elt",    "listp", "numberp", "do",  "gc", "schar",
3099                                  // 84       85        86      87      88        89    90
3100                                  "symbolp","num2str","nconc","first","second","third","fourth",
3101                                  // 91       92       93       94       95      96
3102                                  "fifth", "sixth", "seventh","eighth","ninth","tenth",
3103                                  "substr",       // 97
3104                                  "local_load"    // 98, filename
3105                                };
3106
3107/* select, digistr, load-file are not a common lisp functions! */
3108
3109short sys_args[TOTAL_SYS_FUNCS*2]={
3110
3111// 0      1       2        3       4         5       6      7        8
3112 1, -1,   1, 1,   1, 1,   0, -1,   0, -1,   2, 2,   1, 1,   2, 2,  0, -1,
3113// 9      10      11      12       13       14      15      16      17
3114 1, -1,   2, 3,   2, 2,   0, 0,    2, 2,    1, 1,   2, 2,   2, 2,   1, -1,
3115// 18     19      20      21       22       23      24      25      26
3116 2, -1,  1, 1,   1, 1,  -1, -1,  -1, -1,  -1, -1,  2, 2,   1,-1,   1, 1,
3117// 27      28      29     30       31      32        33,     34      35
3118 1, 1,   -1,-1,  1,-1,  -1, -1,   1,-1,    1, 1,   2, -1,  1,-1,   2,2,
3119// 36     37     38       39       40       41      42      43      44
3120 2,2,    0,0,   0,0,      1,1,    0,-1,    0,-1,   2,2,    1,1,    1,1,
3121// 45     46     47       48       49       50      51      52      53
3122 2,2,    2,2,   2,2,     2,2,     1,1,     1,1,    2,2,    1,1,    1,1,
3123// 54     55     56       57       58       59      60      61      62
3124 1,1,    1,1,   2,2,     1,-1,    0,0,     1,1,    0,0,    2,2,    1,1,
3125// 63     64     65      66        67       68      69      70      71
3126 2,2,    4,-1,  2,-1,    1,1,     1,-1,    1,-1,   1,-1,   1,-1,    2,2,
3127// 72     73     74      75        76       77      78      79       80
3128 2,3,     2,3,  2,3,     1,1,     1,1,     2,2,    2,2,    1,1,     1,1,
3129// 81     82     83      84        85       86      87       88      89
3130 2,3,     0,0,  2,2,     1,1,     1,1,     2,-1,   1,1,     1,1,    1,1,
3131// 90      91    92      93        94       95      96       97     98
3132 1,1,     1,1,   1,1,    1,1,     1,1,      1,1,     1,1,   3,3,    1,1
3133 
3134}; 
3135
3136int total_symbols()
3137{
3138  return ltotal_syms;
3139}
3140
3141void resize_perm(int new_size)
3142{
3143  if (new_size<((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]))
3144  {
3145    lbreak("resize perm : %d is to small to hold current heap\n",new_size);
3146    exit(0);
3147  } else if (new_size>space_size[PERM_SPACE])
3148  {
3149    lbreak("Only smaller resizes allowed for now.\n");
3150    exit(0);
3151  } else
3152    dprintf("doesn't work yet!\n");
3153}
3154
3155void resize_tmp(int new_size)
3156{
3157  if (new_size<((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]))
3158  {
3159    lbreak("resize perm : %d is to small to hold current heap\n",new_size);
3160    exit(0);
3161  } else if (new_size>space_size[TMP_SPACE])
3162  {
3163    printf("Only smaller resizes allowed for now.\n");
3164    exit(0);
3165  } else if (free_space[TMP_SPACE]==space[TMP_SPACE])
3166  {
3167    free_space[TMP_SPACE]=space[TMP_SPACE]=(char *)jrealloc(space[TMP_SPACE],new_size,"lisp tmp space");
3168    space_size[TMP_SPACE]=new_size;
3169    dprintf("Lisp : tmp space resized to %d\n",new_size);
3170  } else dprintf("Lisp :tmp not empty, cannot resize\n");
3171}
3172
3173void l_comp_init();
3174void lisp_init(long perm_size, long tmp_size)
3175{
3176  int i;
3177  lsym_root=NULL;
3178  total_user_functions=0;
3179  free_space[0]=space[0]=(char *)jmalloc(perm_size,"lisp perm space"); 
3180  space_size[0]=perm_size;
3181 
3182
3183  free_space[1]=space[1]=(char *)jmalloc(tmp_size,"lisp tmp space");
3184  space_size[1]=tmp_size;
3185
3186
3187  current_space=PERM_SPACE; 
3188 
3189 
3190  l_comp_init();
3191  for (i=0;i<TOTAL_SYS_FUNCS;i++)
3192    add_sys_function(sys_funcs[i],sys_args[i*2],sys_args[i*2+1],i);
3193  clisp_init();
3194  current_space=TMP_SPACE;
3195  dprintf("Lisp : %d symbols defined, %d system functions, %d pre-compiled functions\n",
3196          total_symbols(),TOTAL_SYS_FUNCS,total_user_functions);
3197}
3198
3199void lisp_uninit()
3200{
3201  jfree(space[0]);
3202  jfree(space[1]);
3203  ldelete_syms(lsym_root);
3204  lsym_root=NULL;
3205  ltotal_syms=0;
3206}
3207
3208void clear_tmp()
3209{
3210  free_space[TMP_SPACE]=space[TMP_SPACE];
3211}
3212
3213void *symbol_name(void *symbol)
3214{
3215  return ((lisp_symbol *)symbol)->name;
3216}
3217
3218
3219void *set_symbol_number(void *symbol, long num)
3220{
3221#ifdef TYPE_CHECKING
3222  if (item_type(symbol)!=L_SYMBOL)
3223  {
3224    lprint(symbol);
3225    lbreak("is not a symbol\n");
3226    exit(0);
3227  }
3228#endif
3229  if (((lisp_symbol *)symbol)->value!=l_undefined &&
3230      item_type(((lisp_symbol *)symbol)->value)==L_NUMBER)
3231    ((lisp_number *)((lisp_symbol *)symbol)->value)->num=num;
3232  else
3233    ((lisp_symbol *)(symbol))->value=new_lisp_number(num);
3234
3235  return ((lisp_symbol *)(symbol))->value;
3236}
3237
3238void *set_symbol_value(void *symbol, void *value)
3239{
3240#ifdef TYPE_CHECKING
3241  if (item_type(symbol)!=L_SYMBOL)
3242  {
3243    lprint(symbol);
3244    lbreak("is not a symbol\n");
3245    exit(0);
3246  }
3247#endif
3248  ((lisp_symbol *)(symbol))->value=value;
3249  return value;
3250}
3251
3252void *symbol_function(void *symbol)
3253{
3254#ifdef TYPE_CHECKING
3255  if (item_type(symbol)!=L_SYMBOL)
3256  {
3257    lprint(symbol);
3258    lbreak("is not a symbol\n");
3259    exit(0);
3260  }
3261#endif
3262  return ((lisp_symbol *)symbol)->function;
3263}
3264
3265void *symbol_value(void *symbol)
3266{
3267#ifdef TYPE_CHECKING
3268  if (item_type(symbol)!=L_SYMBOL)
3269  {
3270    lprint(symbol);
3271    lbreak("is not a symbol\n");
3272    exit(0);
3273  }
3274#endif
3275  return ((lisp_symbol *)symbol)->value;
3276}
3277
3278
3279
3280
3281
3282
Note: See TracBrowser for help on using the repository browser.