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

Last change on this file since 58 was 58, checked in by Sam Hocevar, 14 years ago
  • Remove a few duplicate prototype declarations.
  • Add some harmless "%s" in sprintf() calls.
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 seperate spaces
36   where lisp objects can reside.  Compiled code and gloabal varibles will reside in permanant
37   space.  Eveything else will reside in tmp space which gets thrown away after completion of eval.
38     system functions reside in permant space.
39*/
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.