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

Last change on this file since 49 was 49, checked in by Sam Hocevar, 12 years ago
  • Imported original public domain release, for future reference.
  • Property svn:keywords set to Id
File size: 78.4 KB
Line 
1//#define TYPE_CHECKING 1
2#include "bus_type.hpp"
3
4#include <stdio.h>
5#include <ctype.h>
6#include <stdlib.h>
7#include <string.h>
8#include <stdarg.h>
9
10#include "lisp.hpp"
11#include "lisp_gc.hpp"
12#ifdef NO_LIBS
13#include "fakelib.hpp"
14#else
15#include "status.hpp"
16#include "jmalloc.hpp"
17#include "macs.hpp"
18#include "specs.hpp"
19#include "dprint.hpp"
20#include "cache.hpp"
21#include "dev.hpp"
22#endif
23
24/* To bypass the whole garbage collection issue of lisp I am going to have seperate spaces
25   where lisp objects can reside.  Compiled code and gloabal varibles will reside in permanant
26   space.  Eveything else will reside in tmp space which gets thrown away after completion of eval.
27     system functions reside in permant space.
28*/
29
30bFILE *current_print_file=NULL;
31lisp_symbol *lsym_root=NULL;
32long ltotal_syms=0;
33
34
35
36char *space[4],*free_space[4];
37int space_size[4],print_level=0,trace_level=0,trace_print_level=1000;
38int total_user_functions;
39
40void lprint(void *i);
41
42int current_space;  // normally set to TMP_SPACE, unless compiling or other needs
43
44inline int streq(char *s1, char *s2)   // when you don't need as much as strcmp, this is faster...
45{
46  while (*s1)
47  {
48    if (*(s1++)!=*(s2++))
49      return 0;
50  }
51  return (*s2==0);
52}
53
54int break_level=0;
55
56void l1print(void *block)
57{
58  if (!block)
59    lprint(block);
60  else
61  {
62    if (item_type(block)==L_CONS_CELL)
63    {
64      dprintf("(");
65      for (;block && item_type(block)==L_CONS_CELL;block=CDR(block))
66      {
67        void *a=CAR(block);
68        if (item_type(a)==L_CONS_CELL)
69          dprintf("[...]");
70        else lprint(a);
71      }
72      if (block)
73      {
74        dprintf(" . ");
75        lprint(block);
76      }
77      dprintf(")");
78    } else lprint(block);
79  }
80}
81
82void where_print(int max_lev=-1)
83{
84  dprintf("Main program\n");   
85  if (max_lev==-1) max_lev=l_ptr_stack.son;
86  else if (max_lev>=l_ptr_stack.son) max_lev=l_ptr_stack.son-1;
87
88  for (int i=0;i<max_lev;i++)
89  {
90    dprintf("%d> ",i);
91    lprint(*l_ptr_stack.sdata[i]);
92  }
93}
94
95void print_trace_stack(int max_levels)
96{
97  where_print(max_levels);
98}
99
100void lbreak(const char *format, ...)
101{
102  break_level++;
103  bFILE *old_file=current_print_file;
104  current_print_file=NULL;
105  char st[300];
106  va_list ap;
107  va_start(ap, format);
108  vsprintf(st,format,ap);
109  va_end(ap);
110  dprintf("%s\n",st);
111  int cont=0;
112  do
113  {
114    dprintf("type q to quit\n");
115    dprintf("%d. Break> ",break_level);
116    dgets(st,300);
117    if (!strcmp(st,"c") || !strcmp(st,"cont") || !strcmp(st,"continue"))   
118      cont=1;
119    else if (!strcmp(st,"w") || !strcmp(st,"where"))   
120      where_print();
121    else if (!strcmp(st,"q") || !strcmp(st,"quit"))   
122      exit(1);
123    else if (!strcmp(st,"e") || !strcmp(st,"env") || !strcmp(st,"environment"))   
124    {
125      dprintf("Enviorment : \nnot supported right now\n");
126
127    } else if (!strcmp(st,"h") || !strcmp(st,"help") || !strcmp(st,"?"))   
128    {
129      dprintf("CLIVE Debugger\n");
130      dprintf(" w, where : show calling parents\n"
131              " e, env   : show enviroment\n"
132              " c, cont  : continue if possible\n"
133              " q, quit  : quits the program\n"
134              " h, help  : this\n");
135    }
136    else
137    {
138      char *s=st;
139      do
140      {
141                                void *prog=compile(s);
142                                p_ref r1(prog);
143                                while (*s==' ' || *s=='\t' || *s=='\r' || *s=='\n') s++;
144                                lprint(eval(prog));
145      } while (*s);
146    }
147
148  } while (!cont);
149  current_print_file=old_file;
150  break_level--;
151}
152
153void need_perm_space(char *why)
154{
155  if (current_space!=PERM_SPACE && current_space!=GC_SPACE)
156  { 
157    lbreak("%s : action requires permanant space\n",why);
158    exit(0);
159  }
160}
161
162void *mark_heap(int heap)
163{
164  return free_space[heap]; 
165}
166
167void restore_heap(void *val, int heap)
168{
169  free_space[heap]=(char *)val;
170}
171
172void *lmalloc(int size, int which_space)
173{     
174#ifdef WORD_ALLIGN
175  size=(size+3)&(~3);
176#endif
177
178  if ((char *)free_space[which_space]-(char *)space[which_space]+size>space_size[which_space])
179  {
180    int fart=1;
181    if (which_space==PERM_SPACE)
182    {
183      collect_space(PERM_SPACE);
184      if ((char *)free_space[which_space]-(char *)space[which_space]+size<=space_size[which_space])
185        fart=0;
186    } else if (which_space==TMP_SPACE)
187    {
188      collect_space(TMP_SPACE);
189      if ((char *)free_space[which_space]-(char *)space[which_space]+size<=space_size[which_space])
190        fart=0;
191    }
192    if (fart)
193    {
194      lbreak("lisp : cannot malloc %d bytes in space #%d\n",size,which_space);
195      exit(0);
196    }
197  }
198  void *ret=(void *)free_space[which_space];
199  free_space[which_space]+=size;
200  return ret;
201}
202
203void *eval_block(void *list)
204{
205  p_ref r1(list);
206  void *ret=NULL;
207  while (list)
208  {
209    ret=eval(CAR(list));
210    list=CDR(list);
211  }
212  return ret;
213}
214
215lisp_1d_array *new_lisp_1d_array(ushort size, void *rest)
216{
217  p_ref r11(rest);
218  long s=sizeof(lisp_1d_array)+size*sizeof(void *);
219  if (s<8) s=8;
220  void *p=(lisp_1d_array *)lmalloc(s,current_space);
221  ((lisp_1d_array *)p)->type=L_1D_ARRAY;
222  ((lisp_1d_array *)p)->size=size;
223  void **data=(void **)(((lisp_1d_array *)p)+1);
224  memset(data,0,size*sizeof(void *));
225  p_ref r1(p);
226
227  if (rest)
228  {
229    void *x=eval(CAR(rest));
230    if (x==colon_initial_contents)
231    {
232      x=eval(CAR(CDR(rest)));
233      data=(void **)(((lisp_1d_array *)p)+1);
234      for (int i=0;i<size;i++,x=CDR(x))
235      {
236        if (!x)
237        {
238          lprint(rest);
239          lbreak("(make-array) incorrect list length\n");
240          exit(0);
241        }
242        data[i]=CAR(x);
243      }
244      if (x) { lprint(rest); lbreak("(make-array) incorrect list length\n"); exit(0); }
245    }
246    else if (x==colon_initial_element)
247    {
248      x=eval(CAR(CDR(rest)));
249      data=(void **)(((lisp_1d_array *)p)+1);
250      for (int i=0;i<size;i++)
251        data[i]=x;
252    }
253    else
254    {
255      lprint(x);
256      lbreak("Bad option argument to make-array\n");
257      exit(0);
258    }
259  }
260 
261  return ((lisp_1d_array *)p);
262}
263
264lisp_fixed_point *new_lisp_fixed_point(long x)
265{
266  lisp_fixed_point *p=(lisp_fixed_point *)lmalloc(sizeof(lisp_fixed_point),current_space);
267  p->type=L_FIXED_POINT;
268  p->x=x;
269  return p;
270}
271
272
273lisp_object_var *new_lisp_object_var(short number)
274{
275  lisp_object_var *p=(lisp_object_var *)lmalloc(sizeof(lisp_object_var),current_space);
276  p->type=L_OBJECT_VAR;
277  p->number=number;
278  return p;
279}
280
281
282struct lisp_pointer *new_lisp_pointer(void *addr)
283{
284  if (addr==NULL) return NULL;
285  lisp_pointer *p=(lisp_pointer *)lmalloc(sizeof(lisp_pointer),current_space);
286  p->type=L_POINTER;
287  p->addr=addr;
288  return p;
289}
290
291struct lisp_character *new_lisp_character(unsigned short ch)
292{
293  lisp_character *c=(lisp_character *)lmalloc(sizeof(lisp_character),current_space);
294  c->type=L_CHARACTER;
295  c->ch=ch;
296  return c;
297}
298
299struct lisp_string *new_lisp_string(char *string)
300{
301  long size=sizeof(lisp_string)+strlen(string)+1;
302  if (size<8) size=8;
303
304  lisp_string *s=(lisp_string *)lmalloc(size,current_space);
305  s->type=L_STRING;
306  char *sloc=((char *)s)+sizeof(lisp_string);
307  strcpy(sloc,string);
308  return s;
309}
310
311struct lisp_string *new_lisp_string(char *string, int length)
312{
313  long size=sizeof(lisp_string)+length+1;
314  if (size<8) size=8;
315  lisp_string *s=(lisp_string *)lmalloc(size,current_space);
316  s->type=L_STRING;
317  char *sloc=((char *)s)+sizeof(lisp_string);
318  memcpy(sloc,string,length);
319  sloc[length]=0;
320  return s;
321}
322
323struct lisp_string *new_lisp_string(long length)
324{
325  long size=sizeof(lisp_string)+length;
326  if (size<8) size=8;
327  lisp_string *s=(lisp_string *)lmalloc(size,current_space);
328  s->type=L_STRING;
329  char *sloc=((char *)s)+sizeof(lisp_string);
330  strcpy(sloc,"");
331  return s;
332}
333
334#ifdef NO_LIBS
335lisp_user_function *new_lisp_user_function(void *arg_list, void *block_list)
336{
337  p_ref r1(arg_list),r2(block_list);
338  lisp_user_function *lu=(lisp_user_function *)lmalloc(sizeof(lisp_user_function),current_space);
339  lu->type=L_USER_FUNCTION;
340  lu->arg_list=arg_list;
341  lu->block_list=block_list;
342  return lu;
343}
344#else
345lisp_user_function *new_lisp_user_function(long arg_list, long block_list)
346{
347  int sp=current_space;
348  if (current_space!=GC_SPACE)
349    current_space=PERM_SPACE;       // make sure all functions get defined in permanant space
350
351  lisp_user_function *lu=(lisp_user_function *)lmalloc(sizeof(lisp_user_function),current_space);
352  lu->type=L_USER_FUNCTION;
353  lu->alist=arg_list;
354  lu->blist=block_list;
355
356  current_space=sp;
357
358  return lu;
359}
360#endif
361
362
363lisp_sys_function *new_lisp_sys_function(int min_args, int max_args, int fun_number)
364{
365  // sys functions should reside in permanant space
366  lisp_sys_function *ls=(lisp_sys_function *)lmalloc(sizeof(lisp_sys_function),
367                                                     current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
368  ls->type=L_SYS_FUNCTION;
369  ls->min_args=min_args;
370  ls->max_args=max_args;
371  ls->fun_number=fun_number;
372  return ls;
373}
374
375lisp_sys_function *new_lisp_c_function(int min_args, int max_args,  long (*fun)(void *))
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=fun;
384  return ls;
385}
386
387lisp_sys_function *new_lisp_c_bool(int min_args, int max_args,  long (*fun)(void *))
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=fun;
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,  long (*fun)(void *))
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,fun);
1027  return s;
1028}
1029
1030lisp_symbol *add_c_bool_fun(char *name, short min_args, short max_args,  long (*fun)(void *))
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,fun);
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
1445#ifdef L_PROFILE
1446static int prof_level=0;
1447#endif
1448
1449void *eval_function(lisp_symbol *sym, void *arg_list)
1450{
1451
1452
1453#ifdef TYPE_CHECKING 
1454  int args,req_min,req_max;
1455
1456  if (item_type(sym)!=L_SYMBOL)
1457  {
1458    lprint(sym);
1459    lbreak("EVAL : is not a function name (not symbol either)");
1460    exit(0);
1461  }
1462#endif
1463
1464#ifdef L_PROFILE
1465  time_marker start;
1466  prof_level++;
1467#endif 
1468
1469  void *fun=(lisp_sys_function *)(((lisp_symbol *)sym)->function);
1470  p_ref ref2( fun  );
1471
1472  // make sure the arguments given to the function are the correct number
1473  ltype t=item_type(fun);
1474
1475#ifdef TYPE_CHECKING
1476  switch (t)
1477  {
1478    case L_SYS_FUNCTION :
1479    case L_C_FUNCTION :
1480    case L_C_BOOL :
1481    case L_L_FUNCTION :   
1482    {
1483      req_min=((lisp_sys_function *)fun)->min_args;
1484      req_max=((lisp_sys_function *)fun)->max_args;
1485    } break;
1486    case L_USER_FUNCTION :
1487    {
1488
1489#ifdef L_PROFILE
1490      time_marker end;
1491      if (prof_level<3)
1492        ((lisp_symbol *)sym)->time_taken+=end.diff_time(&start);
1493      prof_level--;
1494#endif 
1495      return eval_user_fun(sym,arg_list);
1496    } break;
1497    default :
1498    {
1499      lprint(sym);
1500      lbreak(" is not a function name");
1501      exit(0); 
1502    } break;
1503  }
1504
1505  if (req_min!=-1)
1506  {
1507    void *a=arg_list;
1508    for (args=0;a;a=CDR(a)) args++;    // count number of paramaters
1509
1510    if (args<req_min)
1511    {
1512      lprint(arg_list);
1513      lprint(sym->name);
1514      lbreak("\nToo few parameters to function\n");
1515      exit(0);
1516    } else if (req_max!=-1 && args>req_max)
1517    {
1518      lprint(arg_list);
1519      lprint(sym->name);
1520      lbreak("\nToo many parameters to function\n");
1521      exit(0);
1522    }
1523  }
1524#endif
1525
1526
1527  p_ref ref1(arg_list);
1528  void *ret=NULL;
1529
1530  switch (t)
1531  {
1532    case L_SYS_FUNCTION :
1533    { ret=eval_sys_function( ((lisp_sys_function *)fun),arg_list); } break;   
1534    case L_L_FUNCTION :
1535    { ret=l_caller( ((lisp_sys_function *)fun)->fun_number,arg_list); } break;
1536    case L_USER_FUNCTION :
1537    {
1538#ifdef L_PROFILE
1539      time_marker end;
1540      if (prof_level<3)
1541        ((lisp_symbol *)sym)->time_taken+=end.diff_time(&start);
1542      prof_level--;
1543#endif 
1544      return eval_user_fun(sym,arg_list);
1545    } break;
1546    case L_C_FUNCTION :
1547    {
1548      void *first=NULL,*cur=NULL;
1549      p_ref r1(first),r2(cur);
1550      while (arg_list)
1551      {
1552                                if (first)
1553                                  cur=((cons_cell *)cur)->cdr=new_cons_cell();
1554                                else
1555                                  cur=first=new_cons_cell();
1556                       
1557                                void *val=eval(CAR(arg_list));
1558                                ((cons_cell *)cur)->car=val;
1559                                arg_list=lcdr(arg_list);
1560      }       
1561      ret=new_lisp_number(((lisp_sys_function *)fun)->fun(first));
1562    } break;
1563    case L_C_BOOL :
1564    {
1565      void *first=NULL,*cur=NULL;
1566      p_ref r1(first),r2(cur);
1567      while (arg_list)
1568      {
1569                                if (first)
1570                                  cur=((cons_cell *)cur)->cdr=new_cons_cell();
1571                                else
1572                                  cur=first=new_cons_cell();
1573                       
1574                                void *val=eval(CAR(arg_list));
1575                                ((cons_cell *)cur)->car=val;
1576                                arg_list=lcdr(arg_list);
1577      }       
1578
1579      if (((lisp_sys_function *)fun)->fun(first))
1580        ret=true_symbol;
1581      else ret=NULL;
1582    } break;
1583    default :
1584      dprintf("not a fun, sholdn't happed\n");
1585  }
1586
1587#ifdef L_PROFILE
1588  time_marker end;
1589  if (prof_level<3)
1590    ((lisp_symbol *)sym)->time_taken+=end.diff_time(&start);
1591  prof_level--;
1592#endif 
1593
1594
1595  return ret;
1596}         
1597
1598#ifdef L_PROFILE
1599void pro_print(bFILE *out, lisp_symbol *p)
1600{
1601  if (p)
1602  {
1603    pro_print(out,p->right);
1604    {
1605      char st[100];
1606      sprintf(st,"%20s %f\n",lstring_value(symbol_name(p)),((lisp_symbol *)p)->time_taken);
1607      out->write(st,strlen(st));
1608    }
1609    pro_print(out,p->left);
1610  }
1611}
1612
1613void preset(lisp_symbol *root)
1614{
1615  if (root)
1616  {
1617    preset(root->right);
1618    preset(root->left);
1619    root->time_taken=0;
1620  }
1621}
1622
1623void preport(char *fn)
1624{
1625  bFILE *fp=open_file("preport.out","wb");
1626  pro_print(fp,lsym_root);
1627  delete fp;
1628}
1629#endif
1630
1631void *mapcar(void *arg_list)
1632{
1633  p_ref ref1(arg_list);
1634  void *sym=eval(CAR(arg_list));
1635  switch ((short)item_type(sym))
1636  {
1637    case L_SYS_FUNCTION :
1638    case L_USER_FUNCTION :
1639    case L_SYMBOL :
1640    break;
1641    default :
1642    {
1643      lprint(sym);
1644      lbreak(" is not a function\n");
1645      exit(0);
1646    }
1647  }
1648  int num_args=list_length(CDR(arg_list)),i,stop=0;
1649  if (!num_args) return 0;
1650
1651  void **arg_on=(void **)jmalloc(sizeof(void *)*num_args,"mapcar tmp array");
1652  cons_cell *list_on=(cons_cell *)CDR(arg_list);
1653  long old_ptr_son=l_ptr_stack.son;
1654
1655  for (i=0;i<num_args;i++)
1656  {
1657    arg_on[i]=(cons_cell *)eval(CAR(list_on));
1658    l_ptr_stack.push(&arg_on[i]);
1659
1660    list_on=(cons_cell *)CDR(list_on);
1661    if (!arg_on[i]) stop=1;
1662  }
1663 
1664  if (stop)
1665  {
1666    jfree(arg_on);
1667    return NULL;
1668  }
1669
1670  cons_cell *na_list=NULL,*return_list=NULL,*last_return;
1671
1672  do
1673  {
1674    na_list=NULL;          // create a cons list with all of the parameters for the function
1675
1676    cons_cell *first;                       // save the start of the list
1677    for (i=0;!stop &&i<num_args;i++)
1678    {
1679      if (!na_list)
1680        first=na_list=new_cons_cell();
1681      else
1682      {
1683        na_list->cdr=new_cons_cell();
1684                                na_list=(cons_cell *)CDR(na_list);
1685      }
1686
1687     
1688      if (arg_on[i])
1689      {
1690                                na_list->car=CAR(arg_on[i]);
1691                                arg_on[i]=(cons_cell *)CDR(arg_on[i]);
1692      }
1693      else stop=1;       
1694    }
1695    if (!stop)
1696    {
1697      cons_cell *c=new_cons_cell();
1698      c->car=eval_function((lisp_symbol *)sym,first);
1699      if (return_list)
1700        last_return->cdr=c;
1701      else
1702        return_list=c;
1703      last_return=c;
1704    }
1705  }
1706  while (!stop);
1707  l_ptr_stack.son=old_ptr_son;
1708
1709  jfree(arg_on);
1710  return return_list;
1711}
1712
1713void *concatenate(void *prog_list)
1714{
1715  void *el_list=CDR(prog_list);
1716  p_ref ref1(prog_list),ref2(el_list);
1717  void *ret=NULL;
1718  void *rtype=eval(CAR(prog_list));
1719
1720  long len=0;                                // determin the length of the resulting string
1721  if (rtype==string_symbol)
1722  {
1723    int elements=list_length(el_list);       // see how many things we need to concat
1724    if (!elements) ret=new_lisp_string("");
1725    else
1726    {
1727      void **str_eval=(void **)jmalloc(elements*sizeof(void *),"tmp eval array");
1728      int i,old_ptr_stack_start=l_ptr_stack.son;
1729
1730      // evalaute all the strings and count their lengths
1731      for (i=0;i<elements;i++,el_list=CDR(el_list))
1732      {
1733        str_eval[i]=eval(CAR(el_list));
1734        l_ptr_stack.push(&str_eval[i]);
1735
1736        switch ((short)item_type(str_eval[i]))
1737        {
1738          case L_CONS_CELL :
1739          {
1740            cons_cell *char_list=(cons_cell *)str_eval[i];
1741            while (char_list)
1742            {
1743              if (item_type(CAR(char_list))==(ltype)L_CHARACTER)
1744                len++;
1745              else
1746              {
1747                lprint(str_eval[i]);
1748                lbreak(" is not a character\n");               
1749                exit(0);
1750              }
1751              char_list=(cons_cell *)CDR(char_list);
1752            }
1753          } break;
1754          case L_STRING : len+=strlen(lstring_value(str_eval[i])); break;
1755          default :
1756            lprint(prog_list);
1757            lbreak("type not supported\n");
1758            exit(0);
1759          break;
1760
1761        }
1762      }
1763      lisp_string *st=new_lisp_string(len+1);
1764      char *s=lstring_value(st);
1765
1766      // now add the string up into the new string
1767      for (i=0;i<elements;i++)
1768      {
1769        switch ((short)item_type(str_eval[i]))
1770        {
1771          case L_CONS_CELL :
1772          {
1773            cons_cell *char_list=(cons_cell *)str_eval[i];
1774            while (char_list)
1775            {
1776              if (item_type(CAR(char_list))==L_CHARACTER)
1777                *(s++)=((lisp_character *)CAR(char_list))->ch;
1778              char_list=(cons_cell *)CDR(char_list);
1779            }
1780          } break;
1781          case L_STRING :
1782          {
1783            memcpy(s,lstring_value(str_eval[i]),strlen(lstring_value(str_eval[i])));
1784            s+=strlen(lstring_value(str_eval[i]));
1785          } break;
1786          default : ;     // already checked for, but make compiler happy
1787        }
1788      }
1789      jfree(str_eval);
1790      l_ptr_stack.son=old_ptr_stack_start;   // restore pointer GC stack
1791      *s=0;     
1792      ret=st;
1793    }
1794  }
1795  else
1796  {
1797    lprint(prog_list);
1798    lbreak("concat operation not supported, try 'string\n");
1799    exit(0);
1800  }
1801  return ret;
1802}
1803
1804
1805void *backquote_eval(void *args)
1806{
1807  if (item_type(args)!=L_CONS_CELL)
1808    return args;
1809  else if (args==NULL)
1810    return NULL;
1811  else if ((lisp_symbol *) (((cons_cell *)args)->car)==comma_symbol)
1812    return eval(CAR(CDR(args)));
1813  else
1814  {
1815    void *first=NULL,*last=NULL,*cur=NULL;
1816    p_ref ref1(first),ref2(last),ref3(cur),ref4(args);
1817    while (args)
1818    {
1819      if (item_type(args)==L_CONS_CELL)
1820      {
1821        if (CAR(args)==comma_symbol)               // dot list with a comma?
1822        {
1823          ((cons_cell *)last)->cdr=eval(CAR(CDR(args)));
1824          args=NULL;
1825        }
1826        else
1827        {
1828          cur=new_cons_cell();
1829          if (first)
1830            ((cons_cell *)last)->cdr=cur;
1831          else
1832            first=cur;
1833          last=cur;
1834          ((cons_cell *)cur)->car=backquote_eval(CAR(args));
1835          args=CDR(args);
1836        }
1837      } else
1838      {
1839        ((cons_cell *)last)->cdr=backquote_eval(args);
1840        args=NULL;
1841      }
1842
1843    }
1844    return (void *)first;
1845  }
1846  return NULL;       // for stupid compiler messages
1847}
1848
1849
1850void *eval_sys_function(lisp_sys_function *fun, void *arg_list)
1851{
1852  p_ref ref1(arg_list);
1853  void *ret=NULL;
1854  switch (fun->fun_number)
1855  {
1856    case 0 :                                                    // print
1857    {
1858      ret=NULL;
1859      while (arg_list)
1860      {
1861        ret=eval(CAR(arg_list));  arg_list=CDR(arg_list);
1862        lprint(ret);
1863      }
1864      return ret;
1865    } break;
1866    case 1 :                                                    // car
1867    { ret=lcar(eval(CAR(arg_list))); } break;
1868    case 2 :                                                    // cdr
1869    { ret=lcdr(eval(CAR(arg_list))); } break;
1870    case 3 :                                                    // length
1871    {
1872      void *v=eval(CAR(arg_list));
1873      switch (item_type(v))
1874      {
1875        case L_STRING : ret=new_lisp_number(strlen(lstring_value(v))); break;
1876        case L_CONS_CELL : ret=new_lisp_number(list_length(v)); break;
1877        default :
1878        { lprint(v);
1879          lbreak("length : type not supported\n");
1880        }
1881      }
1882    } break;                                           
1883    case 4 :                                                    // list
1884    {
1885      void *cur=NULL,*last=NULL,*first=NULL;
1886      p_ref r1(cur),r2(first),r3(last);
1887      while (arg_list)
1888      {
1889        cur=new_cons_cell();
1890        void *val=eval(CAR(arg_list));
1891        ((cons_cell *) cur)->car=val;
1892        if (last)
1893          ((cons_cell *)last)->cdr=cur;
1894        else first=cur;
1895        last=cur;
1896        arg_list=(cons_cell *)CDR(arg_list);
1897      }   
1898      ret=first;
1899    } break;
1900    case 5 :                                             // cons
1901    { void *c=new_cons_cell();
1902      p_ref r1(c);
1903      void *val=eval(CAR(arg_list));
1904      ((cons_cell *)c)->car=val;
1905      val=eval(CAR(CDR(arg_list)));
1906      ((cons_cell *)c)->cdr=val;
1907      ret=c;
1908    } break;
1909    case 6 :                                             // quote
1910    ret=CAR(arg_list);
1911    break;
1912    case 7 :                                             // eq
1913    {
1914      l_user_stack.push(eval(CAR(arg_list)));
1915      l_user_stack.push(eval(CAR(CDR(arg_list))));
1916      ret=lisp_eq(l_user_stack.pop(1),l_user_stack.pop(1));
1917    } break;
1918    case 24 :                                             // equal
1919    {
1920      l_user_stack.push(eval(CAR(arg_list)));
1921      l_user_stack.push(eval(CAR(CDR(arg_list))));
1922      ret=lisp_equal(l_user_stack.pop(1),l_user_stack.pop(1));
1923    } break;
1924    case 8 :                                           // +
1925    {
1926      long sum=0;
1927      while (arg_list)
1928      {
1929        sum+=lnumber_value(eval(CAR(arg_list)));
1930        arg_list=CDR(arg_list);
1931      }
1932      ret=new_lisp_number(sum);
1933    }
1934    break;
1935    case 28 :                                          // *
1936    {
1937      long sum;
1938      void *first=eval(CAR(arg_list));
1939      p_ref r1(first);
1940      if (arg_list && item_type(first)==L_FIXED_POINT)
1941      {
1942        sum=1<<16;
1943        do
1944        {
1945          sum=(sum>>8)*(lfixed_point_value(first)>>8);
1946          arg_list=CDR(arg_list);
1947          if (arg_list) first=eval(CAR(arg_list));
1948        } while (arg_list);
1949
1950        ret=new_lisp_fixed_point(sum);
1951      } else
1952      { sum=1;
1953        do
1954        {
1955          sum*=lnumber_value(eval(CAR(arg_list)));
1956          arg_list=CDR(arg_list);
1957          if (arg_list) first=eval(CAR(arg_list));
1958        } while (arg_list);
1959        ret=new_lisp_number(sum);
1960      }
1961    }
1962    break;
1963    case 29 :                                           // /
1964    {
1965      long sum=0,first=1;
1966      while (arg_list)
1967      {
1968        void *i=eval(CAR(arg_list));
1969        p_ref r1(i);
1970        if (item_type(i)!=L_NUMBER)
1971        {
1972          lprint(i);
1973          lbreak("/ only defined for numbers, cannot divide ");
1974          exit(0);
1975        } else if (first)
1976        {
1977          sum=((lisp_number *)i)->num;
1978          first=0;
1979        }
1980        else sum/=((lisp_number *)i)->num;
1981        arg_list=CDR(arg_list);
1982      }
1983      ret=new_lisp_number(sum);
1984    }
1985    break;
1986    case 9 :                                           // -
1987    {
1988      long x=lnumber_value(eval(CAR(arg_list)));         arg_list=CDR(arg_list);
1989      while (arg_list)
1990      {
1991        x-=lnumber_value(eval(CAR(arg_list)));
1992        arg_list=CDR(arg_list);
1993      }
1994      ret=new_lisp_number(x);
1995    }
1996    break;
1997    case 10 :                                         // if
1998    {
1999      if (eval(CAR(arg_list)))
2000      ret=eval(CAR(CDR(arg_list)));
2001      else
2002      { arg_list=CDR(CDR(arg_list));                 // check for a else part
2003        if (arg_list)   
2004          ret=eval(CAR(arg_list));
2005        else ret=NULL;
2006      }
2007    } break;
2008    case 63 :
2009    case 11 :                                         // setf
2010    {     
2011      void *set_to=eval(CAR(CDR(arg_list))),*i=NULL;
2012      p_ref r1(set_to),r2(i);
2013      i=CAR(arg_list);
2014
2015      ltype x=item_type(set_to);
2016      switch (item_type(i))
2017      {
2018        case L_SYMBOL :
2019        {
2020          switch (item_type (((lisp_symbol *)i)->value))
2021          {
2022            case L_NUMBER :
2023            {
2024              if (x==L_NUMBER && ((lisp_symbol *)i)->value!=l_undefined)
2025              ((lisp_number *)(((lisp_symbol *)i)->value))->num=lnumber_value(set_to);
2026              else
2027              ((lisp_symbol *)i)->value=set_to;
2028            } break;
2029            case L_OBJECT_VAR :
2030            {
2031              l_obj_set(((lisp_object_var *)(((lisp_symbol *)i)->value))->number,set_to); 
2032            } break;
2033            default :
2034            ((lisp_symbol *)i)->value=set_to;
2035          }
2036          ret=((lisp_symbol *)i)->value;
2037        } break;
2038        case L_CONS_CELL :   // this better be an 'aref'
2039        {
2040#ifdef TYPE_CHECKING
2041          void *car=((cons_cell *)i)->car;
2042          if (car==car_symbol)
2043          {
2044            car=eval(CAR(CDR(i)));
2045            if (!car || item_type(car)!=L_CONS_CELL)
2046            { lprint(car); lbreak("setq car : evaled object is not a cons cell\n"); exit(0); }
2047            ((cons_cell *)car)->car=set_to;
2048          } else if (car==cdr_symbol)
2049          {
2050            car=eval(CAR(CDR(i)));
2051            if (!car || item_type(car)!=L_CONS_CELL)
2052            { lprint(car); lbreak("setq cdr : evaled object is not a cons cell\n"); exit(0); }
2053            ((cons_cell *)car)->cdr=set_to;
2054          } else if (car==aref_symbol)
2055          {
2056#endif
2057            void *a=(lisp_1d_array *)eval(CAR(CDR(i)));
2058            p_ref r1(a);
2059#ifdef TYPE_CHECKING
2060            if (item_type(a)!=L_1D_ARRAY)
2061            {
2062              lprint(a);
2063              lbreak("is not an array (aref)\n");
2064              exit(0);
2065            }
2066#endif
2067            long num=lnumber_value(eval(CAR(CDR(CDR(i)))));
2068#ifdef TYPE_CHECKING
2069            if (num>=((lisp_1d_array *)a)->size || num<0)
2070            {
2071              lbreak("aref : value of bounds (%d)\n",num);
2072              exit(0);
2073            }
2074#endif
2075            void **data=(void **)(((lisp_1d_array *)a)+1);
2076            data[num]=set_to;
2077#ifdef TYPE_CHECKING
2078          } else
2079          {
2080            lbreak("expected (aref, car, cdr, or symbol) in setq\n");
2081            exit(0);
2082          }
2083#endif
2084          ret=set_to;
2085        } break;
2086
2087        default :
2088        {
2089          lprint(i);
2090          lbreak("setq/setf only defined for symbols and arrays now..\n");
2091          exit(0);
2092        }
2093      }
2094    } break;
2095    case 12 :                                      // symbol-list
2096      ret=NULL;
2097    break;
2098    case 13 :                                      // assoc
2099    {
2100      void *item=eval(CAR(arg_list));
2101      p_ref r1(item);
2102      void *list=(cons_cell *)eval(CAR(CDR(arg_list)));
2103      p_ref r2(list);
2104      ret=assoc(item,(cons_cell *)list);
2105    } break;
2106    case 20 :                                       // not is the same as null
2107    case 14 :                                       // null
2108    if (eval(CAR(arg_list))==NULL) ret=true_symbol; else ret=NULL;
2109    break;
2110    case 15 :                                       // acons
2111    {
2112      void *i1=eval(CAR(arg_list)),*i2=eval(CAR(CDR(arg_list)));
2113      p_ref r1(i1);
2114      cons_cell *cs=new_cons_cell();
2115      cs->car=i1;
2116      cs->cdr=i2;
2117      ret=cs;
2118    } break;
2119
2120    case 16 :                                       // pairlis
2121    {     
2122      l_user_stack.push(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2123      l_user_stack.push(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2124      void *n3=eval(CAR(arg_list));
2125      void *n2=l_user_stack.pop(1);
2126      void *n1=l_user_stack.pop(1);     
2127      ret=pairlis(n1,n2,n3);
2128    } break;
2129    case 17 :                                      // let
2130    {
2131      // make an a-list of new variable names and new values
2132      void *var_list=CAR(arg_list),
2133           *block_list=CDR(arg_list);
2134      p_ref r1(block_list),r2(var_list);
2135      long stack_start=l_user_stack.son;
2136
2137      while (var_list)
2138      {
2139        void *var_name=CAR(CAR(var_list));
2140#ifdef TYPE_CHECKING
2141        if (item_type(var_name)!=L_SYMBOL)
2142        {
2143          lprint(var_name);
2144          lbreak("should be a symbol (let)\n");
2145          exit(0);
2146        }
2147#endif
2148
2149        l_user_stack.push(((lisp_symbol *)var_name)->value);
2150        ((lisp_symbol *)var_name)->value=eval(CAR(CDR(CAR(var_list))));
2151        var_list=CDR(var_list);
2152      }
2153
2154      // now evaluate each of the blocks with the new enviroment and return value
2155      // from the last block
2156      while (block_list)
2157      {   
2158        ret=eval(CAR(block_list));
2159        block_list=CDR(block_list);         
2160      }
2161
2162      long cur_stack=stack_start;
2163      var_list=CAR(arg_list);      // now restore the old symbol values
2164      while (var_list)
2165      {
2166        void *var_name=CAR(CAR(var_list));
2167        ((lisp_symbol *)var_name)->value=l_user_stack.sdata[cur_stack++];
2168        var_list=CDR(var_list);
2169      }
2170      l_user_stack.son=stack_start;     // restore the stack
2171    }
2172    break;       
2173    case 18 :                                   // defun
2174    {
2175      void *symbol=CAR(arg_list);
2176#ifdef TYPE_CHECKING
2177      if (item_type(symbol)!=L_SYMBOL)
2178      {
2179        lprint(symbol);
2180        lbreak(" is not a symbol! (DEFUN)\n");
2181        exit(0);
2182      }
2183
2184      if (item_type(arg_list)!=L_CONS_CELL)
2185      {
2186        lprint(arg_list);
2187        lbreak("is not a lambda list (DEFUN)\n");
2188        exit(0);
2189      }
2190#endif
2191      void *block_list=CDR(CDR(arg_list));
2192
2193#ifndef NO_LIBS
2194      long a=cash.reg_lisp_block(lcar(lcdr(arg_list)));
2195      long b=cash.reg_lisp_block(block_list);
2196      lisp_user_function *ufun=new_lisp_user_function(a,b);
2197#else
2198      lisp_user_function *ufun=new_lisp_user_function(lcar(lcdr(arg_list)),block_list);
2199#endif
2200      set_symbol_function(symbol,ufun);
2201      ret=symbol;
2202    } break;
2203    case 19 :                                       // atom
2204    { ret=lisp_atom(eval(CAR(arg_list))); }
2205    case 21 :                                           // and
2206    {
2207      void *l=arg_list;
2208      p_ref r1(l);
2209      ret=true_symbol;
2210      while (l)
2211      {
2212        if (!eval(CAR(l)))
2213        {
2214          ret=NULL;
2215          l=NULL;             // short-circuit
2216        } else l=CDR(l);
2217      }
2218    } break;
2219    case 22 :                                           // or
2220    {
2221      void *l=arg_list;
2222      p_ref r1(l);
2223      ret=NULL;
2224      while (l)
2225      {
2226        if (eval(CAR(l)))
2227        {
2228          ret=true_symbol;
2229          l=NULL;            // short circuit
2230        } else l=CDR(l);
2231      }
2232    } break;
2233    case 23 :                                          // progn
2234    { ret=eval_block(arg_list); } break;
2235    case 25 :                                        // concatenate
2236      ret=concatenate(arg_list);
2237    break;
2238    case 26 :                                        // char-code
2239    {
2240      void *i=eval(CAR(arg_list));   
2241      p_ref r1(i);
2242      ret=NULL;
2243      switch (item_type(i))
2244      {
2245        case L_CHARACTER :
2246        { ret=new_lisp_number(((lisp_character *)i)->ch); } break;
2247        case L_STRING :
2248        {  ret=new_lisp_number(*lstring_value(i)); } break;
2249        default :
2250        {
2251          lprint(i);
2252          lbreak(" is not character type\n");
2253          exit(0);
2254        }
2255      }             
2256    } break;
2257    case 27 :                                        // code-char
2258    {
2259      void *i=eval(CAR(arg_list));
2260      p_ref r1(i);
2261      if (item_type(i)!=L_NUMBER)
2262      {
2263        lprint(i);
2264        lbreak(" is not number type\n");
2265        exit(0);
2266      }
2267      ret=new_lisp_character(((lisp_number *)i)->num);
2268    } break;
2269    case 30 :                                       // cond
2270    {
2271      void *block_list=CAR(arg_list);
2272      p_ref r1(block_list);
2273      if (!block_list) ret=NULL;
2274      else
2275      {
2276        ret=NULL;
2277        while (block_list)
2278        {
2279          if (eval(lcar(CAR(block_list))))
2280            ret=eval(CAR(CDR(CAR(block_list))));
2281          block_list=CDR(block_list);
2282        }
2283      }
2284    } break;
2285    case 31 :                                       // select
2286    {
2287      void *selector=eval(CAR(arg_list));
2288      void *sel=CDR(arg_list);
2289      p_ref r1(selector),r2(sel);
2290      while (sel)
2291      {
2292        if (lisp_equal(selector,eval(CAR(CAR(sel)))))
2293        {
2294          sel=CDR(CAR(sel));
2295          while (sel)
2296          {
2297            ret=eval(CAR(sel));
2298            sel=CDR(sel);
2299          }
2300          sel=NULL;
2301        } else sel=CDR(sel);
2302      }
2303    } break;
2304    case 32 :                                      // function   
2305      ret=lookup_symbol_function(eval(CAR(arg_list)));
2306    break;
2307    case 33 :                                      // mapcar
2308      ret=mapcar(arg_list);   
2309    case 34 :                                      // funcall
2310    {
2311      void *n1=eval(CAR(arg_list));
2312      ret=eval_function((lisp_symbol *)n1,CDR(arg_list));     
2313    } break;
2314    case 35 :                                                   // >
2315    {
2316      long n1=lnumber_value(eval(CAR(arg_list)));
2317      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
2318      if (n1>n2) ret=true_symbol; else ret=NULL;
2319    }
2320    break;     
2321    case 36 :                                                   // <
2322    {
2323      long n1=lnumber_value(eval(CAR(arg_list)));
2324      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
2325      if (n1<n2) ret=true_symbol; else ret=NULL;
2326    }   
2327    break;
2328    case 47 :                                                   // >=
2329    {
2330      long n1=lnumber_value(eval(CAR(arg_list)));
2331      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
2332      if (n1>=n2) ret=true_symbol; else ret=NULL;
2333    }
2334    break;     
2335    case 48 :                                                   // <=
2336    {
2337      long n1=lnumber_value(eval(CAR(arg_list)));
2338      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
2339      if (n1<=n2) ret=true_symbol; else ret=NULL;
2340    }   
2341    break;
2342
2343    case 37 :                                                  // tmp-space
2344      tmp_space();
2345      ret=true_symbol;
2346    break;
2347    case 38 :                                                  // perm-space
2348      perm_space();
2349      ret=true_symbol;
2350    break;
2351    case 39 :
2352      void *symb;
2353      symb=eval(CAR(arg_list));
2354#ifdef TYPE_CHECKING
2355      if (item_type(symb)!=L_SYMBOL)
2356      {
2357        lprint(symb);
2358        lbreak(" is not a symbol (symbol-name)\n");
2359        exit(0);
2360      }
2361#endif
2362      ret=((lisp_symbol *)symb)->name;   
2363    break;
2364    case 40 :                                                  // trace
2365      trace_level++;
2366      if (arg_list)
2367        trace_print_level=lnumber_value(eval(CAR(arg_list)));
2368      ret=true_symbol;
2369    break;
2370    case 41 :                                                  // untrace
2371      if (trace_level>0)
2372      {
2373                                trace_level--;
2374                                ret=true_symbol;
2375      } else ret=NULL;
2376    break;
2377    case 42 :                                                 // digitstr
2378    {
2379      char tmp[50],*tp;
2380      long num=lnumber_value(eval(CAR(arg_list)));
2381      long dig=lnumber_value(eval(CAR(CDR(arg_list))));
2382      tp=tmp+49;
2383      *(tp--)=0;
2384      for (;num;)
2385      {
2386                                int d;
2387                                d=num%10;
2388                                *(tp--)=d+'0';
2389                                num/=10;
2390                                dig--;
2391      }
2392      while (dig--)
2393        *(tp--)='0';   
2394      ret=new_lisp_string(tp+1);     
2395    } break;
2396    case 98 : 
2397    case 66 :
2398    case 43 :                                                // compile-file
2399    {
2400      void *fn=eval(CAR(arg_list));
2401      char *st=lstring_value(fn);
2402      p_ref r1(fn);
2403      bFILE *fp;
2404      if (fun->fun_number==98)                              // local load
2405        fp=new jFILE(st,"rb");
2406      else
2407        fp=open_file(st,"rb");
2408
2409      if (fp->open_failure())
2410      {
2411                                delete fp;
2412                                if (DEFINEDP(symbol_value(load_warning)) && symbol_value(load_warning))
2413                                  dprintf("Warning : file %s does not exists\n",st);
2414                                ret=NULL;
2415      }
2416      else
2417      {
2418                                long l=fp->file_size();
2419                                char *s=(char *)jmalloc(l+1,"loaded script");
2420                                if (!s)
2421                                {
2422                                  dprintf("Malloc error in load_script\n"); 
2423                                  exit(0);
2424                                }
2425                       
2426                                fp->read(s,l); 
2427                                s[l]=0;
2428                                delete fp;
2429                                char *cs=s;
2430                        #ifndef NO_LIBS     
2431                                char msg[100];
2432                                sprintf(msg,"(load \"%s\")",st);
2433                                if (stat_man) stat_man->push(msg,NULL);
2434                                crc_man.get_filenumber(st);               // make sure this file gets crc'ed
2435                        #endif
2436                                void *compiled_form=NULL;
2437                                p_ref r11(compiled_form);
2438                                while (!end_of_program(cs))  // see if there is anything left to compile and run
2439                                {
2440                        #ifndef NO_LIBS     
2441                                  if (stat_man) stat_man->update((cs-s)*100/l);
2442                        #endif
2443                                  void *m=mark_heap(TMP_SPACE);
2444                                  compiled_form=compile(cs);
2445                                  eval(compiled_form);
2446                                  compiled_form=NULL;
2447                                  restore_heap(m,TMP_SPACE);
2448                                }       
2449
2450                        #ifndef NO_LIBS
2451                                stat_man->update(100);
2452                                if (stat_man) stat_man->pop();
2453                        #endif     
2454                                jfree(s);
2455                                ret=fn;
2456      }
2457    } break;
2458    case 44 :                                                 // abs
2459      ret=new_lisp_number(abs(lnumber_value(eval(CAR(arg_list))))); break;
2460    case 45 :                                                 // min
2461    {
2462      int x=lnumber_value(eval(CAR(arg_list))),y=lnumber_value(eval(CAR(CDR(arg_list))));
2463      if (x<y) ret=new_lisp_number(x); else ret=new_lisp_number(y);
2464    } break;
2465    case 46 :                                                 // max
2466    {
2467      int x=lnumber_value(eval(CAR(arg_list))),y=lnumber_value(eval(CAR(CDR(arg_list))));
2468      if (x>y) ret=new_lisp_number(x); else ret=new_lisp_number(y);
2469    } break;
2470    case 49 :                        // backquote
2471    {
2472      ret=backquote_eval(CAR(arg_list));
2473    } break;
2474    case 50 :
2475    {
2476      lprint(arg_list);
2477      lbreak("comma is illegal outside of backquote\n");
2478      exit(0);
2479      ret=NULL;
2480    } break;
2481    case 51 :
2482    {
2483      long x=lnumber_value(eval(CAR(arg_list)));
2484      ret=nth(x,eval(CAR(CDR(arg_list))));
2485    } break;
2486    case 52 : resize_tmp(lnumber_value(eval(CAR(arg_list)))); break;
2487    case 53 : resize_perm(lnumber_value(eval(CAR(arg_list)))); break;   
2488    case 54 : ret=new_lisp_fixed_point(lisp_cos(lnumber_value(eval(CAR(arg_list))))); break;
2489    case 55 : ret=new_lisp_fixed_point(lisp_sin(lnumber_value(eval(CAR(arg_list))))); break;
2490    case 56 :
2491    {
2492      long y=(lnumber_value(eval(CAR(arg_list))));   arg_list=CDR(arg_list);
2493      long x=(lnumber_value(eval(CAR(arg_list))));
2494      ret=new_lisp_number(lisp_atan2(y,x));     
2495    } break;
2496    case 57 :
2497    {
2498      int sp=current_space;
2499      current_space=PERM_SPACE;
2500      long x=0;
2501      while (arg_list)
2502      {
2503        void *sym=eval(CAR(arg_list));
2504        p_ref r1(sym);
2505        switch (item_type(sym))
2506        {
2507          case L_SYMBOL :
2508          { ((lisp_symbol *)sym)->value=new_lisp_number(x); } break;
2509          case L_CONS_CELL :
2510          {
2511            void *s=eval(CAR(sym));
2512            p_ref r1(s);
2513#ifdef TYPE_CHECKING
2514            if (item_type(s)!=L_SYMBOL)
2515            { lprint(arg_list);
2516              lbreak("expecting (sybmol value) for enum\n");
2517              exit(0);
2518            }
2519#endif
2520            x=lnumber_value(eval(CAR(CDR(sym))));
2521            ((lisp_symbol *)sym)->value=new_lisp_number(x);
2522          } break;
2523          default :
2524          {
2525            lprint(arg_list);
2526            lbreak("expecting symbol or (symbol value) in enum\n");
2527            exit(0);
2528          }
2529        }
2530        arg_list=CDR(arg_list);
2531        x++;
2532      }     
2533      current_space=sp;
2534    } break;
2535    case 58 :
2536    {
2537      exit(0);
2538    } break;
2539    case 59 :
2540    {
2541      ret=eval(eval(CAR(arg_list)));
2542    } break;
2543    case 60 : lbreak("User break"); break;
2544    case 61 :
2545    {
2546      long x=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2547      long y=lnumber_value(eval(CAR(arg_list)));
2548      if (y==0) { lbreak("mod : division by zero\n"); y=1; }     
2549      ret=new_lisp_number(x%y);
2550    } break;
2551/*    case 62 :
2552    {
2553      char *fn=lstring_value(eval(CAR(arg_list)));
2554      FILE *fp=fopen(fn,"wb");
2555      if (!fp)
2556        lbreak("could not open %s for writing",fn);
2557      else
2558      {
2559        for (void *s=symbol_list;s;s=CDR(s))             
2560          fprintf(fp,"%8d  %s\n",((lisp_symbol *)(CAR(s)))->call_counter,
2561                  lstring_value(((lisp_symbol *)(CAR(s)))->name));
2562        fclose(fp);
2563      }
2564    } break;*/
2565    case 64 :
2566    {
2567      void *bind_var=CAR(arg_list); arg_list=CDR(arg_list);
2568      p_ref r1(bind_var);
2569      if (item_type(bind_var)!=L_SYMBOL)
2570      { lbreak("expecting for iterator to be a symbol\n"); exit(1); }
2571
2572      if (CAR(arg_list)!=in_symbol)
2573      { lbreak("expecting in after 'for iterator'\n"); exit(1); }
2574      arg_list=CDR(arg_list);
2575
2576      void *ilist=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2577      p_ref r2(ilist);
2578     
2579      if (CAR(arg_list)!=do_symbol)
2580      { lbreak("expecting do after 'for iterator in list'\n"); exit(1); }
2581      arg_list=CDR(arg_list);
2582
2583      void *block=NULL,*ret=NULL;
2584      p_ref r3(block);
2585      l_user_stack.push(symbol_value(bind_var));  // save old symbol value
2586      while (ilist)
2587      {
2588                                set_symbol_value(bind_var,CAR(ilist));
2589                                for (block=arg_list;block;block=CDR(block))
2590                                  ret=eval(CAR(block));
2591                                ilist=CDR(ilist);
2592      }
2593      set_symbol_value(bind_var,l_user_stack.pop(1));
2594      ret=ret;
2595    } break;
2596    case 65 :
2597    {
2598      bFILE *old_file=current_print_file;
2599      void *str1=eval(CAR(arg_list));
2600      p_ref r1(str1);
2601      void *str2=eval(CAR(CDR(arg_list)));
2602     
2603     
2604      current_print_file=open_file(lstring_value(str1),
2605                                   lstring_value(str2));
2606
2607      if (!current_print_file->open_failure())
2608      {
2609                                while (arg_list)
2610                                {
2611                                  ret=eval(CAR(arg_list));       
2612                                  arg_list=CDR(arg_list);
2613                                }
2614      }     
2615      delete current_print_file;
2616      current_print_file=old_file;     
2617
2618    } break;
2619    case 67 :
2620    {
2621      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2622      while (arg_list)
2623      {
2624        first&=lnumber_value(eval(CAR(arg_list)));
2625                                arg_list=CDR(arg_list);
2626      }
2627      ret=new_lisp_number(first);
2628    } break;
2629    case 68 :
2630    {
2631      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2632      while (arg_list)
2633      {
2634        first|=lnumber_value(eval(CAR(arg_list)));
2635                                arg_list=CDR(arg_list);
2636      }
2637      ret=new_lisp_number(first);
2638    } break;
2639    case 69 :
2640    {
2641      long first=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2642      while (arg_list)
2643      {
2644        first^=lnumber_value(eval(CAR(arg_list)));
2645                                arg_list=CDR(arg_list);
2646      }
2647      ret=new_lisp_number(first);
2648    } break;
2649    case 70 :  // make-array
2650    {
2651      long l=lnumber_value(eval(CAR(arg_list)));
2652      if (l>=2<<16 || l<=0)
2653      {
2654                                lbreak("bad array size %d\n",l);
2655                                exit(0);
2656      }
2657      ret=new_lisp_1d_array(l,CDR(arg_list));
2658    } break;
2659    case 71 : // aref
2660    {
2661      long x=lnumber_value(eval(CAR(CDR(arg_list))));
2662      ret=lget_array_element(eval(CAR(arg_list)),x);
2663    } break;
2664    case 72 : // if-1progn
2665    {
2666      if (eval(CAR(arg_list)))
2667        ret=eval_block(CAR(CDR(arg_list)));
2668      else ret=eval(CAR(CDR(CDR(arg_list))));
2669
2670    } break;
2671    case 73 : // if-2progn
2672    {
2673      if (eval(CAR(arg_list)))
2674        ret=eval(CAR(CDR(arg_list)));
2675      else ret=eval_block(CAR(CDR(CDR(arg_list))));
2676
2677    } break;
2678    case 74 : // if-12progn
2679    {
2680      if (eval(CAR(arg_list)))
2681        ret=eval_block(CAR(CDR(arg_list)));
2682      else ret=eval_block(CAR(CDR(CDR(arg_list))));
2683
2684    } break;
2685    case 75 : // eq0
2686    {
2687      void *v=eval(CAR(arg_list));
2688      if (item_type(v)!=L_NUMBER || (((lisp_number *)v)->num!=0))
2689        ret=NULL;
2690      else ret=true_symbol;
2691    } break;
2692    case 76 : // preport
2693    {
2694#ifdef L_PROFILE
2695      char *s=lstring_value(eval(CAR(arg_list)));     
2696      preport(s);
2697#endif
2698    } break;
2699    case 77 : // search
2700    {
2701      void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2702      p_ref r1(arg1);       // protect this refrence
2703      char *haystack=lstring_value(eval(CAR(arg_list)));     
2704      char *needle=lstring_value(arg1);
2705
2706      char *find=strstr(haystack,needle);
2707      if (find)
2708        ret=new_lisp_number(find-haystack);
2709      else ret=NULL;
2710    } break;
2711    case 78 : // elt
2712    {
2713      void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list);
2714      p_ref r1(arg1);       // protect this refrence
2715      long x=lnumber_value(eval(CAR(arg_list)));           
2716      char *st=lstring_value(arg1);
2717      if (x<0 || x>=strlen(st))
2718      { lbreak("elt : out of range of string\n"); ret=NULL; }
2719      else
2720        ret=new_lisp_character(st[x]);     
2721    } break;
2722    case 79 : // listp
2723    {
2724      return item_type(eval(CAR(arg_list)))==L_CONS_CELL ? true_symbol : NULL;
2725    } break;
2726    case 80 : // numberp
2727    {
2728      int t=item_type(eval(CAR(arg_list)));
2729      if (t==L_NUMBER || t==L_FIXED_POINT) return true_symbol; else return NULL;
2730    } break;
2731    case 81 : // do
2732    {
2733      void *init_var=CAR(arg_list);
2734      p_ref r1(init_var);
2735      int i,ustack_start=l_user_stack.son;      // restore stack at end
2736      void *sym=NULL;
2737      p_ref r2(sym);
2738
2739      // check to make sure iter vars are symbol and push old values
2740      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
2741      {
2742                                sym=CAR(CAR(init_var));
2743                                if (item_type(sym)!=L_SYMBOL)
2744                                { lbreak("expecting symbol name for iteration var\n"); exit(0); }
2745                                l_user_stack.push(symbol_value(sym));
2746      }
2747     
2748      void **do_evaled=l_user_stack.sdata+l_user_stack.son;
2749      // push all of the init forms, so we can set the symbol
2750      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))   
2751                                l_user_stack.push(eval(CAR(CDR(CAR((init_var))))));
2752
2753      // now set all the symbols
2754      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)
2755      {
2756                                sym=CAR(CAR(init_var));
2757                                set_symbol_value(sym,*do_evaled);
2758      }
2759
2760      i=0;       // set i to 1 when terminate conditions are meet
2761      do
2762      {
2763                                i=(eval(CAR(CAR(CDR(arg_list))))!=NULL);
2764                                if (!i)
2765                                {
2766                                  eval_block(CDR(CDR(arg_list)));
2767                                  for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
2768                                    eval(CAR(CDR(CDR(CAR(init_var)))));
2769                                }
2770      } while (!i);
2771     
2772      ret=eval(CAR(CDR(CAR(CDR(arg_list)))));
2773
2774      // restore old values for symbols
2775      do_evaled=l_user_stack.sdata+ustack_start;
2776      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)     
2777      {
2778                                sym=CAR(CAR(init_var));
2779                                set_symbol_value(sym,*do_evaled);
2780      }
2781
2782      l_user_stack.son=ustack_start;
2783     
2784    } break;
2785    case 82 : // gc
2786    {
2787      collect_space(current_space);
2788    } break;
2789    case 83 : // schar
2790    {
2791      char *s=lstring_value(eval(CAR(arg_list)));      arg_list=CDR(arg_list);
2792      long x=lnumber_value(eval(CAR(arg_list)));
2793
2794      if (x>=strlen(s))
2795      { lbreak("SCHAR: index %d should be less than the length of the string\n",x); exit(0); }
2796      else if (x<0)
2797      { lbreak("SCHAR: index should not be negative\n"); exit(0); }
2798      return new_lisp_character(s[x]);
2799    } break;
2800    case 84 :// symbolp
2801    { if (item_type(eval(CAR(arg_list)))==L_SYMBOL) return true_symbol;
2802      else return NULL; } break;
2803    case 85 :  // num2str
2804    {
2805      char str[10];
2806      sprintf(str,"%d",lnumber_value(eval(CAR(arg_list))));
2807      ret=new_lisp_string(str);
2808    } break;
2809    case 86 : // nconc
2810    {
2811      void *l1=eval(CAR(arg_list)); arg_list=CDR(arg_list);           
2812      p_ref r1(l1);     
2813      void *first=l1,*next;
2814      p_ref r2(first);
2815
2816      if (!l1)
2817      {
2818                                l1=first=eval(CAR(arg_list));
2819                                arg_list=CDR(arg_list);
2820      }
2821     
2822      if (item_type(l1)!=L_CONS_CELL)
2823      { lprint(l1); lbreak("first arg should be a list\n"); }
2824      do
2825      {
2826                                next=l1;
2827                                while (next) { l1=next; next=lcdr(next); }
2828                                ((cons_cell *)l1)->cdr=eval(CAR(arg_list));     
2829                                arg_list=CDR(arg_list);
2830      } while (arg_list);     
2831      ret=first;
2832    } break;
2833    case 87 : // first
2834    { ret=CAR(eval(CAR(arg_list))); } break;
2835    case 88 : // second
2836    { ret=CAR(CDR(eval(CAR(arg_list)))); } break;
2837    case 89 : // third
2838    { ret=CAR(CDR(CDR(eval(CAR(arg_list))))); } break;
2839    case 90 : // fourth
2840    { ret=CAR(CDR(CDR(CDR(eval(CAR(arg_list)))))); } break;
2841    case 91 : // fifth
2842    { ret=CAR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))); } break;
2843    case 92 : // sixth
2844    { ret=CAR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))); } break;
2845    case 93 : // seventh
2846    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))))); } break;
2847    case 94 : // eight
2848    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))))); } break;
2849    case 95 : // ninth
2850    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list))))))))))); } break;
2851    case 96 : // tenth
2852    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(eval(CAR(arg_list)))))))))))); } break;
2853    case 97 :
2854    {
2855      long x1=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2856      long x2=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
2857      void *st=eval(CAR(arg_list));
2858      p_ref r1(st);
2859
2860      if (x1<0 || x1>x2 || x2>=strlen(lstring_value(st)))
2861        lbreak("substr : bad x1 or x2 value");
2862     
2863      lisp_string *s=new_lisp_string(x2-x1+2);
2864      if (x2-x1)
2865        memcpy(lstring_value(s),lstring_value(st)+x1,x2-x1+1);
2866
2867      *(lstring_value(s)+(x2-x1+1))=0;
2868      ret=s;
2869    } break;
2870
2871    case 99 : // preset
2872    {
2873#ifdef L_PROFILE
2874      preset(lsym_root);
2875#endif
2876    } break;
2877
2878    default :
2879    { dprintf("Undefined system function number %d\n",((lisp_sys_function *)fun)->fun_number); }
2880  }
2881  return ret;
2882}
2883
2884void tmp_space()
2885{
2886  current_space=TMP_SPACE;
2887}
2888
2889void perm_space()
2890{
2891  current_space=PERM_SPACE;
2892}
2893
2894void use_user_space(void *addr, long size)
2895{
2896  current_space=2;
2897  free_space[USER_SPACE]=space[USER_SPACE]=(char *)addr;
2898  space_size[USER_SPACE]=size;
2899}
2900
2901
2902void *eval_user_fun(lisp_symbol *sym, void *arg_list)
2903{
2904  int args,req_min,req_max;
2905  void *ret=NULL;
2906  p_ref ref1(ret);
2907
2908#ifdef TYPE_CHECKING
2909  if (item_type(sym)!=L_SYMBOL)
2910  {
2911    lprint(sym);
2912    lbreak("EVAL : is not a function name (not symbol either)");
2913    exit(0);
2914  }
2915#endif
2916
2917
2918  lisp_user_function *fun=(lisp_user_function *)(((lisp_symbol *)sym)->function);
2919
2920#ifdef TYPE_CHECKING
2921  if (item_type(fun)!=L_USER_FUNCTION)
2922  {
2923    lprint(sym);
2924    lbreak("is not a user defined function\n");
2925  }
2926#endif
2927
2928#ifndef NO_LIBS
2929  void *fun_arg_list=cash.lblock(fun->alist);
2930  void *block_list=cash.lblock(fun->blist);
2931  p_ref r9(block_list),r10(fun_arg_list);
2932#else
2933  void *fun_arg_list=fun->arg_list;
2934  void *block_list=fun->block_list;
2935  p_ref r9(block_list),r10(fun_arg_list);
2936#endif
2937
2938
2939
2940  // mark the start start, so we can restore when done
2941  long stack_start=l_user_stack.son; 
2942
2943  // first push all of the old symbol values
2944  void *f_arg=fun_arg_list;
2945  p_ref r18(f_arg);
2946  p_ref r19(arg_list);
2947  for (;f_arg;f_arg=CDR(f_arg))
2948  {
2949    l_user_stack.push(((lisp_symbol *)CAR(f_arg))->value);
2950  }
2951
2952  // open block so that local vars aren't saved on the stack
2953  {
2954    int new_start=l_user_stack.son;
2955    int i=new_start;
2956    // now push all the values we wish to gather
2957    for (f_arg=fun_arg_list;f_arg;)
2958    {
2959      if (!arg_list)
2960      { lprint(sym);  lbreak("too few parameter to function\n"); exit(0); }
2961      l_user_stack.push(eval(CAR(arg_list)));
2962      f_arg=CDR(f_arg);
2963      arg_list=CDR(arg_list);
2964    }
2965
2966
2967    // now store all the values and put them into the symbols
2968    for (f_arg=fun_arg_list;f_arg;f_arg=CDR(f_arg))
2969      ((lisp_symbol *)CAR(f_arg))->value=l_user_stack.sdata[i++];
2970
2971    l_user_stack.son=new_start;
2972  }
2973
2974
2975
2976  if (f_arg)
2977  { lprint(sym);  lbreak("too many parameter to function\n"); exit(0); }
2978
2979
2980  // now evaluate the function block
2981  while (block_list)
2982  {
2983    ret=eval(CAR(block_list));
2984    block_list=CDR(block_list);   
2985  }
2986
2987  long cur_stack=stack_start;
2988  for (f_arg=fun_arg_list;f_arg;f_arg=CDR(f_arg))
2989    ((lisp_symbol *)CAR(f_arg))->value=l_user_stack.sdata[cur_stack++];
2990
2991  l_user_stack.son=stack_start;
2992
2993
2994  return ret;
2995}
2996
2997
2998
2999
3000
3001void *eval(void *prog)
3002{
3003 
3004
3005  void *ret=NULL; 
3006  p_ref ref1(prog);
3007
3008
3009  int tstart=trace_level;
3010 
3011  if (trace_level)
3012  {
3013    if (trace_level<=trace_print_level)
3014    {
3015      dprintf("%d (%d,%d,%d) TRACE : ",trace_level,
3016              space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
3017              space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
3018              l_ptr_stack.son);
3019      lprint(prog);
3020
3021      dprintf("\n");
3022    }
3023    trace_level++;
3024  }
3025  if (prog)
3026  {
3027    switch (item_type(prog))
3028    {   
3029      case L_BAD_CELL :
3030      { lbreak("error : eval on a bad cell\n"); exit(0); } break;
3031      case L_CHARACTER :
3032      case L_STRING :
3033      case L_NUMBER :
3034      case L_POINTER :
3035      case L_FIXED_POINT :
3036      { ret=prog; } break;
3037      case L_SYMBOL :
3038      { if (prog==true_symbol)
3039                                ret=prog;
3040        else
3041                                {
3042                                  ret=lookup_symbol_value(prog);
3043                                  if (item_type(ret)==L_OBJECT_VAR)
3044                                    ret=l_obj_get(((lisp_object_var *)ret)->number);
3045                                }
3046      } break;
3047      case L_CONS_CELL :
3048      {
3049        ret=eval_function((lisp_symbol *)CAR(prog),CDR(prog));
3050      }
3051      break;
3052      default :
3053        dprintf("shouldn't happen\n");
3054    }
3055  }
3056  if (tstart)
3057  {
3058    trace_level--;
3059    if (trace_level<=trace_print_level)
3060      dprintf("%d (%d,%d,%d) TRACE ==> ",trace_level,
3061              space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
3062              space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
3063              l_ptr_stack.son);
3064    lprint(ret);
3065    dprintf("\n");
3066  }
3067 
3068/*  l_user_stack.push(ret);
3069  collect_space(PERM_SPACE);
3070  ret=l_user_stack.pop(1);  */
3071
3072
3073  return ret;
3074}
3075
3076#define TOTAL_SYS_FUNCS 100
3077                                 //  0      1    2       3       4      5      6      7
3078char *sys_funcs[TOTAL_SYS_FUNCS]={"print","car","cdr","length","list","cons","quote","eq",
3079                                // 8   9   10    11       12          13     14      15      16
3080                                  "+","-","if","setf","symbol-list","assoc","null","acons","pairlis",
3081                                // 17     18     19     20     21     22    23      24
3082                                  "let","defun","atom","not", "and", "or","progn","equal",
3083                                // 25               26          27       28  29   30     31
3084                                  "concatenate","char-code","code-char","*","/","cond","select",
3085                                // 32            33         34     35    36    37       
3086                                  "function", "mapcar", "funcall", ">", "<", "tmp-space",
3087                                //   38              39        40       41         42
3088                                  "perm-space","symbol-name","trace","untrace","digstr",
3089                                //   43            44   45    46    47  48       49
3090                                  "compile-file","abs","min","max",">=","<=","backquote",
3091                                //  50      51      52         53           54    55     56
3092                                  "comma","nth","resize-tmp","resize-perm","cos","sin","atan2",
3093                                  // 57       58     59     60     61   62              63
3094                                  "enum", "quit","eval","break","mod","write_profile","setq",
3095                                  // 64    65          66      67       68        69        70
3096                                  "for", "open_file","load","bit-and","bit-or","bit-xor","make-array",
3097                                  // 71      72          73          74        75      76
3098                                  "aref","if-1progn","if-2progn","if-12progn","eq0","preport",
3099                                  // 77     78         79        80       81     82     83
3100                                  "search","elt",    "listp", "numberp", "do",  "gc", "schar",
3101                                  // 84       85        86      87      88        89    90
3102                                  "symbolp","num2str","nconc","first","second","third","fourth",
3103                                  // 91       92       93       94       95      96
3104                                  "fifth", "sixth", "seventh","eighth","ninth","tenth",
3105                                  "substr",       // 97
3106                                  "local_load",    // 98, filename
3107                                  "preset"        // 99
3108                                };
3109
3110/* select, digistr, load-file are not a common lisp functions! */
3111
3112short sys_args[TOTAL_SYS_FUNCS*2]={
3113
3114// 0      1       2        3       4         5       6      7        8
3115 1, -1,   1, 1,   1, 1,   0, -1,   0, -1,   2, 2,   1, 1,   2, 2,  0, -1,
3116// 9      10      11      12       13       14      15      16      17
3117 1, -1,   2, 3,   2, 2,   0, 0,    2, 2,    1, 1,   2, 2,   2, 2,   1, -1,
3118// 18     19      20      21       22       23      24      25      26
3119 2, -1,  1, 1,   1, 1,  -1, -1,  -1, -1,  -1, -1,  2, 2,   1,-1,   1, 1,
3120// 27      28      29     30       31      32        33,     34      35
3121 1, 1,   -1,-1,  1,-1,  -1, -1,   1,-1,    1, 1,   2, -1,  1,-1,   2,2,
3122// 36     37     38       39       40       41      42      43      44
3123 2,2,    0,0,   0,0,      1,1,    0,-1,    0,-1,   2,2,    1,1,    1,1,
3124// 45     46     47       48       49       50      51      52      53
3125 2,2,    2,2,   2,2,     2,2,     1,1,     1,1,    2,2,    1,1,    1,1,
3126// 54     55     56       57       58       59      60      61      62
3127 1,1,    1,1,   2,2,     1,-1,    0,0,     1,1,    0,0,    2,2,    1,1,
3128// 63     64     65      66        67       68      69      70      71
3129 2,2,    4,-1,  2,-1,    1,1,     1,-1,    1,-1,   1,-1,   1,-1,    2,2,
3130// 72     73     74      75        76       77      78      79       80
3131 2,3,     2,3,  2,3,     1,1,     1,1,     2,2,    2,2,    1,1,     1,1,
3132// 81     82     83      84        85       86      87       88      89
3133 2,3,     0,0,  2,2,     1,1,     1,1,     2,-1,   1,1,     1,1,    1,1,
3134// 90      91    92      93        94       95      96       97     98
3135 1,1,     1,1,   1,1,    1,1,     1,1,      1,1,     1,1,   3,3,    1,1
3136 
3137}; 
3138
3139int total_symbols()
3140{
3141  return ltotal_syms;
3142}
3143
3144void resize_perm(int new_size)
3145{
3146  if (new_size<((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]))
3147  {
3148    lbreak("resize perm : %d is to small to hold current heap\n",new_size);
3149    exit(0);
3150  } else if (new_size>space_size[PERM_SPACE])
3151  {
3152    lbreak("Only smaller resizes allowed for now.\n");
3153    exit(0);
3154  } else
3155    dprintf("doesn't work yet!\n");
3156}
3157
3158void resize_tmp(int new_size)
3159{
3160  if (new_size<((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]))
3161  {
3162    lbreak("resize perm : %d is to small to hold current heap\n",new_size);
3163    exit(0);
3164  } else if (new_size>space_size[TMP_SPACE])
3165  {
3166    dprintf("Only smaller resizes allowed for now.\n");
3167    exit(0);
3168  } else if (free_space[TMP_SPACE]==space[TMP_SPACE])
3169  {
3170    free_space[TMP_SPACE]=space[TMP_SPACE]=(char *)jrealloc(space[TMP_SPACE],new_size,"lisp tmp space");
3171    space_size[TMP_SPACE]=new_size;
3172    dprintf("Lisp : tmp space resized to %d\n",new_size);
3173  } else dprintf("Lisp :tmp not empty, cannot resize\n");
3174}
3175
3176void l_comp_init();
3177void lisp_init(long perm_size, long tmp_size)
3178{
3179  int i;
3180  lsym_root=NULL;
3181  total_user_functions=0;
3182  free_space[0]=space[0]=(char *)jmalloc(perm_size,"lisp perm space"); 
3183  space_size[0]=perm_size;
3184 
3185
3186  free_space[1]=space[1]=(char *)jmalloc(tmp_size,"lisp tmp space");
3187  space_size[1]=tmp_size;
3188
3189
3190  current_space=PERM_SPACE; 
3191 
3192 
3193  l_comp_init();
3194  for (i=0;i<TOTAL_SYS_FUNCS;i++)
3195    add_sys_function(sys_funcs[i],sys_args[i*2],sys_args[i*2+1],i);
3196  clisp_init();
3197  current_space=TMP_SPACE;
3198  dprintf("Lisp : %d symbols defined, %d system functions, %d pre-compiled functions\n",
3199          total_symbols(),TOTAL_SYS_FUNCS,total_user_functions);
3200}
3201
3202void lisp_uninit()
3203{
3204#ifdef L_PROFILE
3205  preport("preport.out");
3206#endif
3207
3208  jfree(space[0]);
3209  jfree(space[1]);
3210  ldelete_syms(lsym_root);
3211  lsym_root=NULL;
3212  ltotal_syms=0;
3213}
3214
3215void clear_tmp()
3216{
3217  free_space[TMP_SPACE]=space[TMP_SPACE];
3218}
3219
3220void *symbol_name(void *symbol)
3221{
3222  return ((lisp_symbol *)symbol)->name;
3223}
3224
3225
3226void *set_symbol_number(void *symbol, long num)
3227{
3228#ifdef TYPE_CHECKING
3229  if (item_type(symbol)!=L_SYMBOL)
3230  {
3231    lprint(symbol);
3232    lbreak("is not a symbol\n");
3233    exit(0);
3234  }
3235#endif
3236  if (((lisp_symbol *)symbol)->value!=l_undefined &&
3237      item_type(((lisp_symbol *)symbol)->value)==L_NUMBER)
3238    ((lisp_number *)((lisp_symbol *)symbol)->value)->num=num;
3239  else
3240    ((lisp_symbol *)(symbol))->value=new_lisp_number(num);
3241
3242  return ((lisp_symbol *)(symbol))->value;
3243}
3244
3245void *set_symbol_value(void *symbol, void *value)
3246{
3247#ifdef TYPE_CHECKING
3248  if (item_type(symbol)!=L_SYMBOL)
3249  {
3250    lprint(symbol);
3251    lbreak("is not a symbol\n");
3252    exit(0);
3253  }
3254#endif
3255  ((lisp_symbol *)(symbol))->value=value;
3256  return value;
3257}
3258
3259void *symbol_function(void *symbol)
3260{
3261#ifdef TYPE_CHECKING
3262  if (item_type(symbol)!=L_SYMBOL)
3263  {
3264    lprint(symbol);
3265    lbreak("is not a symbol\n");
3266    exit(0);
3267  }
3268#endif
3269  return ((lisp_symbol *)symbol)->function;
3270}
3271
3272void *symbol_value(void *symbol)
3273{
3274#ifdef TYPE_CHECKING
3275  if (item_type(symbol)!=L_SYMBOL)
3276  {
3277    lprint(symbol);
3278    lbreak("is not a symbol\n");
3279    exit(0);
3280  }
3281#endif
3282  return ((lisp_symbol *)symbol)->value;
3283}
3284
3285
3286
3287
3288
3289
Note: See TracBrowser for help on using the repository browser.