source: abuse/tags/pd/abuse/src/lisp.c @ 49

Last change on this file since 49 was 49, checked in by Sam Hocevar, 11 years ago
  • Imported original public domain release, for future reference.
  • Property svn:keywords set to Id
File size: 78.1 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,"%d",&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,"%d",((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;
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;                       // 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        fp=new jFILE(st,"rb");
2375      else
2376        fp=open_file(st,"rb");
2377
2378      if (fp->open_failure())
2379      {
2380                                delete fp;
2381                                if (DEFINEDP(symbol_value(load_warning)) && symbol_value(load_warning))
2382                                  dprintf("Warning : file %s does not exists\n",st);
2383                                ret=NULL;
2384      }
2385      else
2386      {
2387                                long l=fp->file_size();
2388                                char *s=(char *)jmalloc(l+1,"loaded script");
2389                                if (!s)
2390                                {
2391                                  printf("Malloc error in load_script\n"); 
2392                                  exit(0);
2393                                }
2394                       
2395                                fp->read(s,l); 
2396                                s[l]=0;
2397                                delete fp;
2398                                char *cs=s;
2399                        #ifndef NO_LIBS     
2400                                char msg[100];
2401                                sprintf(msg,"(load \"%s\")",st);
2402                                if (stat_man) stat_man->push(msg,NULL);
2403                                crc_man.get_filenumber(st);               // make sure this file gets crc'ed
2404                        #endif
2405                                void *compiled_form=NULL;
2406                                p_ref r11(compiled_form);
2407                                while (!end_of_program(cs))  // see if there is anything left to compile and run
2408                                {
2409                        #ifndef NO_LIBS     
2410                                  if (stat_man) stat_man->update((cs-s)*100/l);
2411                        #endif
2412                                  void *m=mark_heap(TMP_SPACE);
2413                                  compiled_form=compile(cs);
2414                                  eval(compiled_form);
2415                                  compiled_form=NULL;
2416                                  restore_heap(m,TMP_SPACE);
2417                                }       
2418                        #ifndef NO_LIBS
2419                                if (stat_man) stat_man->update(100);
2420                                if (stat_man) stat_man->pop();
2421                        #endif     
2422                                jfree(s);
2423                                ret=fn;
2424      }
2425    } break;
2426    case 44 :                                                 // abs
2427      ret=new_lisp_number(abs(lnumber_value(eval(CAR(arg_list))))); break;
2428    case 45 :                                                 // min
2429    {
2430      int x=lnumber_value(eval(CAR(arg_list))),y=lnumber_value(eval(CAR(CDR(arg_list))));
2431      if (x<y) ret=new_lisp_number(x); else ret=new_lisp_number(y);
2432    } break;
2433    case 46 :                                                 // max
2434    {
2435      int x=lnumber_value(eval(CAR(arg_list))),y=lnumber_value(eval(CAR(CDR(arg_list))));
2436      if (x>y) ret=new_lisp_number(x); else ret=new_lisp_number(y);
2437    } break;
2438    case 49 :                        // backquote
2439    {
2440      ret=backquote_eval(CAR(arg_list));
2441    } break;
2442    case 50 :
2443    {
2444      lprint(arg_list);
2445      lbreak("comma is illegal outside of backquote\n");
2446      exit(0);
2447      ret=NULL;
2448    } break;
2449    case 51 :
2450    {
2451      long x=lnumber_value(eval(CAR(arg_list)));
2452      ret=nth(x,eval(CAR(CDR(arg_list))));
2453    } break;
2454    case 52 : resize_tmp(lnumber_value(eval(CAR(arg_list)))); break;
2455    case 53 : resize_perm(lnumber_value(eval(CAR(arg_list)))); break;   
2456    case 54 : ret=new_lisp_fixed_point(lisp_cos(lnumber_value(eval(CAR(arg_list))))); break;
2457    case 55 : ret=new_lisp_fixed_point(lisp_sin(lnumber_value(eval(CAR(arg_list))))); break;
2458    case 56 :
2459    {
2460      long y=(lnumber_value(eval(CAR(arg_list))));   arg_list=CDR(arg_list);
2461      long x=(lnumber_value(eval(CAR(arg_list))));
2462      ret=new_lisp_number(lisp_atan2(y,x));     
2463    } break;
2464    case 57 :
2465    {
2466      int sp=current_space;
2467      current_space=PERM_SPACE;
2468      long x=0;
2469      while (arg_list)
2470      {
2471        void *sym=eval(CAR(arg_list));
2472        p_ref r1(sym);
2473        switch (item_type(sym))
2474        {
2475          case L_SYMBOL :
2476          { ((lisp_symbol *)sym)->value=new_lisp_number(x); } break;
2477          case L_CONS_CELL :
2478          {
2479            void *s=eval(CAR(sym));
2480            p_ref r1(s);
2481#ifdef TYPE_CHECKING
2482            if (item_type(s)!=L_SYMBOL)
2483            { lprint(arg_list);
2484              lbreak("expecting (sybmol value) for enum\n");
2485              exit(0);
2486            }
2487#endif
2488            x=lnumber_value(eval(CAR(CDR(sym))));
2489            ((lisp_symbol *)sym)->value=new_lisp_number(x);
2490          } break;
2491          default :
2492          {
2493            lprint(arg_list);
2494            lbreak("expecting symbol or (symbol value) in enum\n");
2495            exit(0);
2496          }
2497        }
2498        arg_list=CDR(arg_list);
2499        x++;
2500      }     
2501      current_space=sp;
2502    } break;
2503    case 58 :
2504    {
2505      exit(0);
2506    } break;
2507    case 59 :
2508    {
2509      ret=eval(eval(CAR(arg_list)));
2510    } break;
2511    case 60 : lbreak("User break"); break;
2512    case 61 :
2513    {
2514      long x=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2515      long y=lnumber_value(eval(CAR(arg_list)));
2516      if (y==0) { lbreak("mod : division by zero\n"); y=1; }     
2517      ret=new_lisp_number(x%y);
2518    } break;
2519/*    case 62 :
2520    {
2521      char *fn=lstring_value(eval(CAR(arg_list)));
2522      FILE *fp=fopen(fn,"wb");
2523      if (!fp)
2524        lbreak("could not open %s for writing",fn);
2525      else
2526      {
2527        for (void *s=symbol_list;s;s=CDR(s))             
2528          fprintf(fp,"%8d  %s\n",((lisp_symbol *)(CAR(s)))->call_counter,
2529                  lstring_value(((lisp_symbol *)(CAR(s)))->name));
2530        fclose(fp);
2531      }
2532    } break;*/
2533    case 64 :
2534    {
2535      void *bind_var=CAR(arg_list); arg_list=CDR(arg_list);
2536      p_ref r1(bind_var);
2537      if (item_type(bind_var)!=L_SYMBOL)
2538      { lbreak("expecting for iterator to be a symbol\n"); exit(1); }
2539
2540      if (CAR(arg_list)!=in_symbol)
2541      { lbreak("expecting in after 'for iterator'\n"); exit(1); }
2542      arg_list=CDR(arg_list);
2543
2544      void *ilist=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2545      p_ref r2(ilist);
2546     
2547      if (CAR(arg_list)!=do_symbol)
2548      { lbreak("expecting do after 'for iterator in list'\n"); exit(1); }
2549      arg_list=CDR(arg_list);
2550
2551      void *block=NULL,*ret=NULL;
2552      p_ref r3(block);
2553      l_user_stack.push(symbol_value(bind_var));  // save old symbol value
2554      while (ilist)
2555      {
2556                                set_symbol_value(bind_var,CAR(ilist));
2557                                for (block=arg_list;block;block=CDR(block))
2558                                  ret=eval(CAR(block));
2559                                ilist=CDR(ilist);
2560      }
2561      set_symbol_value(bind_var,l_user_stack.pop(1));
2562      ret=ret;
2563    } break;
2564    case 65 :
2565    {
2566      bFILE *old_file=current_print_file;
2567      void *str1=eval(CAR(arg_list));
2568      p_ref r1(str1);
2569      void *str2=eval(CAR(CDR(arg_list)));
2570     
2571     
2572      current_print_file=open_file(lstring_value(str1),
2573                                   lstring_value(str2));
2574
2575      if (!current_print_file->open_failure())
2576      {
2577                                while (arg_list)
2578                                {
2579                                  ret=eval(CAR(arg_list));       
2580                                  arg_list=CDR(arg_list);
2581                                }
2582      }     
2583      delete current_print_file;
2584      current_print_file=old_file;     
2585
2586    } break;
2587    case 67 :
2588    {
2589      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2590      while (arg_list)
2591      {
2592        first&=lnumber_value(eval(CAR(arg_list)));
2593                                arg_list=CDR(arg_list);
2594      }
2595      ret=new_lisp_number(first);
2596    } break;
2597    case 68 :
2598    {
2599      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2600      while (arg_list)
2601      {
2602        first|=lnumber_value(eval(CAR(arg_list)));
2603                                arg_list=CDR(arg_list);
2604      }
2605      ret=new_lisp_number(first);
2606    } break;
2607    case 69 :
2608    {
2609      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2610      while (arg_list)
2611      {
2612        first^=lnumber_value(eval(CAR(arg_list)));
2613                                arg_list=CDR(arg_list);
2614      }
2615      ret=new_lisp_number(first);
2616    } break;
2617    case 70 :  // make-array
2618    {
2619      long l=lnumber_value(eval(CAR(arg_list)));
2620      if (l>=2<<16 || l<=0)
2621      {
2622                                lbreak("bad array size %d\n",l);
2623                                exit(0);
2624      }
2625      ret=new_lisp_1d_array(l,CDR(arg_list));
2626    } break;
2627    case 71 : // aref
2628    {
2629      long x=lnumber_value(eval(CAR(CDR(arg_list))));
2630      ret=lget_array_element(eval(CAR(arg_list)),x);
2631    } break;
2632    case 72 : // if-1progn
2633    {
2634      if (eval(CAR(arg_list)))
2635        ret=eval_block(CAR(CDR(arg_list)));
2636      else ret=eval(CAR(CDR(CDR(arg_list))));
2637
2638    } break;
2639    case 73 : // if-2progn
2640    {
2641      if (eval(CAR(arg_list)))
2642        ret=eval(CAR(CDR(arg_list)));
2643      else ret=eval_block(CAR(CDR(CDR(arg_list))));
2644
2645    } break;
2646    case 74 : // if-12progn
2647    {
2648      if (eval(CAR(arg_list)))
2649        ret=eval_block(CAR(CDR(arg_list)));
2650      else ret=eval_block(CAR(CDR(CDR(arg_list))));
2651
2652    } break;
2653    case 75 : // eq0
2654    {
2655      void *v=eval(CAR(arg_list));
2656      if (item_type(v)!=L_NUMBER || (((lisp_number *)v)->num!=0))
2657        ret=NULL;
2658      else ret=true_symbol;
2659    } break;
2660    case 76 : // preport
2661    {
2662#ifdef L_PROFILE
2663      char *s=lstring_value(eval(CAR(arg_list)));     
2664      preport(s);
2665#endif
2666    } break;
2667    case 77 : // search
2668    {
2669      void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2670      p_ref r1(arg1);       // protect this refrence
2671      char *haystack=lstring_value(eval(CAR(arg_list)));     
2672      char *needle=lstring_value(arg1);
2673
2674      char *find=strstr(haystack,needle);
2675      if (find)
2676        ret=new_lisp_number(find-haystack);
2677      else ret=NULL;
2678    } break;
2679    case 78 : // elt
2680    {
2681      void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2682      p_ref r1(arg1);       // protect this refrence
2683      long x=lnumber_value(eval(CAR(arg_list)));           
2684      char *st=lstring_value(arg1);
2685      if (x<0 || x>=strlen(st))
2686      { lbreak("elt : out of range of string\n"); ret=NULL; }
2687      else
2688        ret=new_lisp_character(st[x]);     
2689    } break;
2690    case 79 : // listp
2691    {
2692      return item_type(eval(CAR(arg_list)))==L_CONS_CELL ? true_symbol : NULL;
2693    } break;
2694    case 80 : // numberp
2695    {
2696      int t=item_type(eval(CAR(arg_list)));
2697      if (t==L_NUMBER || t==L_FIXED_POINT) return true_symbol; else return NULL;
2698    } break;
2699    case 81 : // do
2700    {
2701      void *init_var=CAR(arg_list);
2702      p_ref r1(init_var);
2703      int i,ustack_start=l_user_stack.son;      // restore stack at end
2704      void *sym=NULL;
2705      p_ref r2(sym);
2706
2707      // check to make sure iter vars are symbol and push old values
2708      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
2709      {
2710                                sym=CAR(CAR(init_var));
2711                                if (item_type(sym)!=L_SYMBOL)
2712                                { lbreak("expecting symbol name for iteration var\n"); exit(0); }
2713                                l_user_stack.push(symbol_value(sym));
2714      }
2715     
2716      void **do_evaled=l_user_stack.sdata+l_user_stack.son;
2717      // push all of the init forms, so we can set the symbol
2718      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))   
2719                                l_user_stack.push(eval(CAR(CDR(CAR((init_var))))));
2720
2721      // now set all the symbols
2722      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)
2723      {
2724                                sym=CAR(CAR(init_var));
2725                                set_symbol_value(sym,*do_evaled);
2726      }
2727
2728      i=0;       // set i to 1 when terminate conditions are meet
2729      do
2730      {
2731                                i=(eval(CAR(CAR(CDR(arg_list))))!=NULL);
2732                                if (!i)
2733                                {
2734                                  eval_block(CDR(CDR(arg_list)));
2735                                  for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
2736                                    eval(CAR(CDR(CDR(CAR(init_var)))));
2737                                }
2738      } while (!i);
2739     
2740      ret=eval(CAR(CDR(CAR(CDR(arg_list)))));
2741
2742      // restore old values for symbols
2743      do_evaled=l_user_stack.sdata+ustack_start;
2744      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)     
2745      {
2746                                sym=CAR(CAR(init_var));
2747                                set_symbol_value(sym,*do_evaled);
2748      }
2749
2750      l_user_stack.son=ustack_start;
2751     
2752    } break;
2753    case 82 : // gc
2754    {
2755      collect_space(current_space);
2756    } break;
2757    case 83 : // schar
2758    {
2759      char *s=lstring_value(eval(CAR(arg_list)));      arg_list=CDR(arg_list);
2760      long x=lnumber_value(eval(CAR(arg_list)));
2761
2762      if (x>=strlen(s))
2763      { lbreak("SCHAR: index %d should be less than the length of the string\n",x); exit(0); }
2764      else if (x<0)
2765      { lbreak("SCHAR: index should not be negative\n"); exit(0); }
2766      return new_lisp_character(s[x]);
2767    } break;
2768    case 84 :// symbolp
2769    { if (item_type(eval(CAR(arg_list)))==L_SYMBOL) return true_symbol;
2770      else return NULL; } break;
2771    case 85 :  // num2str
2772    {
2773      char str[10];
2774      sprintf(str,"%d",lnumber_value(eval(CAR(arg_list))));
2775      ret=new_lisp_string(str);
2776    } break;
2777    case 86 : // nconc
2778    {
2779      void *l1=eval(CAR(arg_list)); arg_list=CDR(arg_list);           
2780      p_ref r1(l1);     
2781      void *first=l1,*next;
2782      p_ref r2(first);
2783
2784      if (!l1)
2785      {
2786                                l1=first=eval(CAR(arg_list));
2787                                arg_list=CDR(arg_list);
2788      }
2789     
2790      if (item_type(l1)!=L_CONS_CELL)
2791      { lprint(l1); lbreak("first arg should be a list\n"); }
2792      do
2793      {
2794                                next=l1;
2795                                while (next) { l1=next; next=lcdr(next); }
2796                                ((cons_cell *)l1)->cdr=eval(CAR(arg_list));     
2797                                arg_list=CDR(arg_list);
2798      } while (arg_list);     
2799      ret=first;
2800    } break;
2801    case 87 : // first
2802    { ret=CAR(eval(CAR(arg_list))); } break;
2803    case 88 : // second
2804    { ret=CAR(CDR(eval(CAR(arg_list)))); } break;
2805    case 89 : // third
2806    { ret=CAR(CDR(CDR(eval(CAR(arg_list))))); } break;
2807    case 90 : // fourth
2808    { ret=CAR(CDR(CDR(CDR(eval(CAR(arg_list)))))); } break;
2809    case 91 : // fifth
2810    { ret=CAR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))); } break;
2811    case 92 : // sixth
2812    { ret=CAR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))); } break;
2813    case 93 : // seventh
2814    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))))); } break;
2815    case 94 : // eight
2816    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))))); } break;
2817    case 95 : // ninth
2818    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))))))); } break;
2819    case 96 : // tenth
2820    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))))))); } break;
2821    case 97 :
2822    {
2823      long x1=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2824      long x2=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2825      void *st=eval(CAR(arg_list));
2826      p_ref r1(st);
2827
2828      if (x1<0 || x1>x2 || x2>=strlen(lstring_value(st)))
2829        lbreak("substr : bad x1 or x2 value");
2830     
2831      lisp_string *s=new_lisp_string(x2-x1+2);
2832      if (x2-x1)
2833        memcpy(lstring_value(s),lstring_value(st)+x1,x2-x1+1);
2834
2835      *(lstring_value(s)+(x2-x1+1))=0;
2836      ret=s;
2837    } break;
2838    case 99 :
2839    {
2840      void *r=NULL,*rstart=NULL;
2841      p_ref r1(r),r2(rstart);
2842      while (arg_list)
2843      {
2844                                void *q=eval(CAR(arg_list));
2845                                if (!rstart) rstart=q;
2846                                while (r && CDR(r)) r=CDR(r);
2847                                CDR(r)=q;         
2848                                arg_list=CDR(arg_list);
2849      }
2850      return rstart;
2851    } break;
2852
2853    default :
2854    { dprintf("Undefined system function number %d\n",((lisp_sys_function *)fun)->fun_number); }
2855  }
2856  return ret;
2857}
2858
2859void tmp_space()
2860{
2861  current_space=TMP_SPACE;
2862}
2863
2864void perm_space()
2865{
2866  current_space=PERM_SPACE;
2867}
2868
2869void use_user_space(void *addr, long size)
2870{
2871  current_space=2;
2872  free_space[USER_SPACE]=space[USER_SPACE]=(char *)addr;
2873  space_size[USER_SPACE]=size;
2874}
2875
2876
2877void *eval_user_fun(lisp_symbol *sym, void *arg_list)
2878{
2879  int args,req_min,req_max;
2880  void *ret=NULL;
2881  p_ref ref1(ret);
2882
2883#ifdef TYPE_CHECKING
2884  if (item_type(sym)!=L_SYMBOL)
2885  {
2886    lprint(sym);
2887    lbreak("EVAL : is not a function name (not symbol either)");
2888    exit(0);
2889  }
2890#endif
2891#ifdef L_PROFILE
2892  time_marker start;
2893#endif 
2894
2895
2896  lisp_user_function *fun=(lisp_user_function *)(((lisp_symbol *)sym)->function);
2897
2898#ifdef TYPE_CHECKING
2899  if (item_type(fun)!=L_USER_FUNCTION)
2900  {
2901    lprint(sym);
2902    lbreak("is not a user defined function\n");
2903  }
2904#endif
2905
2906#ifndef NO_LIBS
2907  void *fun_arg_list=cash.lblock(fun->alist);
2908  void *block_list=cash.lblock(fun->blist);
2909  p_ref r9(block_list),r10(fun_arg_list);
2910#else
2911  void *fun_arg_list=fun->arg_list;
2912  void *block_list=fun->block_list;
2913  p_ref r9(block_list),r10(fun_arg_list);
2914#endif
2915
2916
2917
2918  // mark the start start, so we can restore when done
2919  long stack_start=l_user_stack.son; 
2920
2921  // first push all of the old symbol values
2922  void *f_arg=fun_arg_list;
2923  p_ref r18(f_arg);
2924  p_ref r19(arg_list);
2925  for (;f_arg;f_arg=CDR(f_arg))
2926  {
2927    l_user_stack.push(((lisp_symbol *)CAR(f_arg))->value);
2928  }
2929
2930  // open block so that local vars aren't saved on the stack
2931  {
2932    int new_start=l_user_stack.son;
2933    int i=new_start;
2934    // now push all the values we wish to gather
2935    for (f_arg=fun_arg_list;f_arg;)
2936    {
2937      if (!arg_list)
2938      { lprint(sym);  lbreak("too few parameter to function\n"); exit(0); }
2939      l_user_stack.push(eval(CAR(arg_list)));
2940      f_arg=CDR(f_arg);
2941      arg_list=CDR(arg_list);
2942    }
2943
2944
2945    // now store all the values and put them into the symbols
2946    for (f_arg=fun_arg_list;f_arg;f_arg=CDR(f_arg))
2947      ((lisp_symbol *)CAR(f_arg))->value=l_user_stack.sdata[i++];
2948
2949    l_user_stack.son=new_start;
2950  }
2951
2952
2953
2954  if (f_arg)
2955  { lprint(sym);  lbreak("too many parameter to function\n"); exit(0); }
2956
2957
2958  // now evaluate the function block
2959  while (block_list)
2960  {
2961    ret=eval(CAR(block_list));
2962    block_list=CDR(block_list);   
2963  }
2964
2965  long cur_stack=stack_start;
2966  for (f_arg=fun_arg_list;f_arg;f_arg=CDR(f_arg))
2967    ((lisp_symbol *)CAR(f_arg))->value=l_user_stack.sdata[cur_stack++];
2968
2969  l_user_stack.son=stack_start;
2970
2971#ifdef L_PROFILE
2972  time_marker end;
2973  ((lisp_symbol *)sym)->time_taken+=end.diff_time(&start);
2974#endif 
2975
2976
2977  return ret;
2978}
2979
2980
2981
2982
2983
2984void *eval(void *prog)
2985{
2986 
2987
2988  void *ret=NULL; 
2989  p_ref ref1(prog);
2990
2991
2992  int tstart=trace_level;
2993 
2994  if (trace_level)
2995  {
2996    if (trace_level<=trace_print_level)
2997    {
2998      dprintf("%d (%d,%d,%d) TRACE : ",trace_level,
2999              space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
3000              space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
3001              l_ptr_stack.son);
3002      lprint(prog);
3003
3004      dprintf("\n");
3005    }
3006    trace_level++;
3007  }
3008  if (prog)
3009  {
3010    switch (item_type(prog))
3011    {   
3012      case L_BAD_CELL :
3013      { lbreak("error : eval on a bad cell\n"); exit(0); } break;
3014      case L_CHARACTER :
3015      case L_STRING :
3016      case L_NUMBER :
3017      case L_POINTER :
3018      case L_FIXED_POINT :
3019      { ret=prog; } break;
3020      case L_SYMBOL :
3021      { if (prog==true_symbol)
3022                                ret=prog;
3023        else
3024                                {
3025                                  ret=lookup_symbol_value(prog);
3026                                  if (item_type(ret)==L_OBJECT_VAR)
3027                                    ret=l_obj_get(((lisp_object_var *)ret)->number);
3028                                }
3029      } break;
3030      case L_CONS_CELL :
3031      {
3032        ret=eval_function((lisp_symbol *)CAR(prog),CDR(prog));
3033      }
3034      break;
3035      default :
3036        fprintf(stderr,"shouldn't happen\n");
3037    }
3038  }
3039  if (tstart)
3040  {
3041    trace_level--;
3042    if (trace_level<=trace_print_level)
3043      dprintf("%d (%d,%d,%d) TRACE ==> ",trace_level,
3044              space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
3045              space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
3046              l_ptr_stack.son);
3047    lprint(ret);
3048    dprintf("\n");
3049  }
3050 
3051/*  l_user_stack.push(ret);
3052  collect_space(PERM_SPACE);
3053  ret=l_user_stack.pop(1);  */
3054
3055
3056  return ret;
3057}
3058
3059#define TOTAL_SYS_FUNCS 99
3060                                 //  0      1    2       3       4      5      6      7
3061char *sys_funcs[TOTAL_SYS_FUNCS]={"print","car","cdr","length","list","cons","quote","eq",
3062                                // 8   9   10    11       12          13     14      15      16
3063                                  "+","-","if","setf","symbol-list","assoc","null","acons","pairlis",
3064                                // 17     18     19     20     21     22    23      24
3065                                  "let","defun","atom","not", "and", "or","progn","equal",
3066                                // 25               26          27       28  29   30     31
3067                                  "concatenate","char-code","code-char","*","/","cond","select",
3068                                // 32            33         34     35    36    37       
3069                                  "function", "mapcar", "funcall", ">", "<", "tmp-space",
3070                                //   38              39        40       41         42
3071                                  "perm-space","symbol-name","trace","untrace","digstr",
3072                                //   43            44   45    46    47  48       49
3073                                  "compile-file","abs","min","max",">=","<=","backquote",
3074                                //  50      51      52         53           54    55     56
3075                                  "comma","nth","resize-tmp","resize-perm","cos","sin","atan2",
3076                                  // 57       58     59     60     61   62              63
3077                                  "enum", "quit","eval","break","mod","write_profile","setq",
3078                                  // 64    65          66      67       68        69        70
3079                                  "for", "open_file","load","bit-and","bit-or","bit-xor","make-array",
3080                                  // 71      72          73          74        75      76
3081                                  "aref","if-1progn","if-2progn","if-12progn","eq0","preport",
3082                                  // 77     78         79        80       81     82     83
3083                                  "search","elt",    "listp", "numberp", "do",  "gc", "schar",
3084                                  // 84       85        86      87      88        89    90
3085                                  "symbolp","num2str","nconc","first","second","third","fourth",
3086                                  // 91       92       93       94       95      96
3087                                  "fifth", "sixth", "seventh","eighth","ninth","tenth",
3088                                  "substr",       // 97
3089                                  "local_load"    // 98, filename
3090                                };
3091
3092/* select, digistr, load-file are not a common lisp functions! */
3093
3094short sys_args[TOTAL_SYS_FUNCS*2]={
3095
3096// 0      1       2        3       4         5       6      7        8
3097 1, -1,   1, 1,   1, 1,   0, -1,   0, -1,   2, 2,   1, 1,   2, 2,  0, -1,
3098// 9      10      11      12       13       14      15      16      17
3099 1, -1,   2, 3,   2, 2,   0, 0,    2, 2,    1, 1,   2, 2,   2, 2,   1, -1,
3100// 18     19      20      21       22       23      24      25      26
3101 2, -1,  1, 1,   1, 1,  -1, -1,  -1, -1,  -1, -1,  2, 2,   1,-1,   1, 1,
3102// 27      28      29     30       31      32        33,     34      35
3103 1, 1,   -1,-1,  1,-1,  -1, -1,   1,-1,    1, 1,   2, -1,  1,-1,   2,2,
3104// 36     37     38       39       40       41      42      43      44
3105 2,2,    0,0,   0,0,      1,1,    0,-1,    0,-1,   2,2,    1,1,    1,1,
3106// 45     46     47       48       49       50      51      52      53
3107 2,2,    2,2,   2,2,     2,2,     1,1,     1,1,    2,2,    1,1,    1,1,
3108// 54     55     56       57       58       59      60      61      62
3109 1,1,    1,1,   2,2,     1,-1,    0,0,     1,1,    0,0,    2,2,    1,1,
3110// 63     64     65      66        67       68      69      70      71
3111 2,2,    4,-1,  2,-1,    1,1,     1,-1,    1,-1,   1,-1,   1,-1,    2,2,
3112// 72     73     74      75        76       77      78      79       80
3113 2,3,     2,3,  2,3,     1,1,     1,1,     2,2,    2,2,    1,1,     1,1,
3114// 81     82     83      84        85       86      87       88      89
3115 2,3,     0,0,  2,2,     1,1,     1,1,     2,-1,   1,1,     1,1,    1,1,
3116// 90      91    92      93        94       95      96       97     98
3117 1,1,     1,1,   1,1,    1,1,     1,1,      1,1,     1,1,   3,3,    1,1
3118 
3119}; 
3120
3121int total_symbols()
3122{
3123  return ltotal_syms;
3124}
3125
3126void resize_perm(int new_size)
3127{
3128  if (new_size<((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]))
3129  {
3130    lbreak("resize perm : %d is to small to hold current heap\n",new_size);
3131    exit(0);
3132  } else if (new_size>space_size[PERM_SPACE])
3133  {
3134    lbreak("Only smaller resizes allowed for now.\n");
3135    exit(0);
3136  } else
3137    dprintf("doesn't work yet!\n");
3138}
3139
3140void resize_tmp(int new_size)
3141{
3142  if (new_size<((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]))
3143  {
3144    lbreak("resize perm : %d is to small to hold current heap\n",new_size);
3145    exit(0);
3146  } else if (new_size>space_size[TMP_SPACE])
3147  {
3148    printf("Only smaller resizes allowed for now.\n");
3149    exit(0);
3150  } else if (free_space[TMP_SPACE]==space[TMP_SPACE])
3151  {
3152    free_space[TMP_SPACE]=space[TMP_SPACE]=(char *)jrealloc(space[TMP_SPACE],new_size,"lisp tmp space");
3153    space_size[TMP_SPACE]=new_size;
3154    dprintf("Lisp : tmp space resized to %d\n",new_size);
3155  } else dprintf("Lisp :tmp not empty, cannot resize\n");
3156}
3157
3158void l_comp_init();
3159void lisp_init(long perm_size, long tmp_size)
3160{
3161  int i;
3162  lsym_root=NULL;
3163  total_user_functions=0;
3164  free_space[0]=space[0]=(char *)jmalloc(perm_size,"lisp perm space"); 
3165  space_size[0]=perm_size;
3166 
3167
3168  free_space[1]=space[1]=(char *)jmalloc(tmp_size,"lisp tmp space");
3169  space_size[1]=tmp_size;
3170
3171
3172  current_space=PERM_SPACE; 
3173 
3174 
3175  l_comp_init();
3176  for (i=0;i<TOTAL_SYS_FUNCS;i++)
3177    add_sys_function(sys_funcs[i],sys_args[i*2],sys_args[i*2+1],i);
3178  clisp_init();
3179  current_space=TMP_SPACE;
3180  dprintf("Lisp : %d symbols defined, %d system functions, %d pre-compiled functions\n",
3181          total_symbols(),TOTAL_SYS_FUNCS,total_user_functions);
3182}
3183
3184void lisp_uninit()
3185{
3186  jfree(space[0]);
3187  jfree(space[1]);
3188  ldelete_syms(lsym_root);
3189  lsym_root=NULL;
3190  ltotal_syms=0;
3191}
3192
3193void clear_tmp()
3194{
3195  free_space[TMP_SPACE]=space[TMP_SPACE];
3196}
3197
3198void *symbol_name(void *symbol)
3199{
3200  return ((lisp_symbol *)symbol)->name;
3201}
3202
3203
3204void *set_symbol_number(void *symbol, long num)
3205{
3206#ifdef TYPE_CHECKING
3207  if (item_type(symbol)!=L_SYMBOL)
3208  {
3209    lprint(symbol);
3210    lbreak("is not a symbol\n");
3211    exit(0);
3212  }
3213#endif
3214  if (((lisp_symbol *)symbol)->value!=l_undefined &&
3215      item_type(((lisp_symbol *)symbol)->value)==L_NUMBER)
3216    ((lisp_number *)((lisp_symbol *)symbol)->value)->num=num;
3217  else
3218    ((lisp_symbol *)(symbol))->value=new_lisp_number(num);
3219
3220  return ((lisp_symbol *)(symbol))->value;
3221}
3222
3223void *set_symbol_value(void *symbol, void *value)
3224{
3225#ifdef TYPE_CHECKING
3226  if (item_type(symbol)!=L_SYMBOL)
3227  {
3228    lprint(symbol);
3229    lbreak("is not a symbol\n");
3230    exit(0);
3231  }
3232#endif
3233  ((lisp_symbol *)(symbol))->value=value;
3234  return value;
3235}
3236
3237void *symbol_function(void *symbol)
3238{
3239#ifdef TYPE_CHECKING
3240  if (item_type(symbol)!=L_SYMBOL)
3241  {
3242    lprint(symbol);
3243    lbreak("is not a symbol\n");
3244    exit(0);
3245  }
3246#endif
3247  return ((lisp_symbol *)symbol)->function;
3248}
3249
3250void *symbol_value(void *symbol)
3251{
3252#ifdef TYPE_CHECKING
3253  if (item_type(symbol)!=L_SYMBOL)
3254  {
3255    lprint(symbol);
3256    lbreak("is not a symbol\n");
3257    exit(0);
3258  }
3259#endif
3260  return ((lisp_symbol *)symbol)->value;
3261}
3262
3263
3264
3265
3266
3267
Note: See TracBrowser for help on using the repository browser.