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

Last change on this file since 162 was 162, checked in by Sam Hocevar, 12 years ago

Fix numerous compiler warnings.

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