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

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