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

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