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

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