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

Last change on this file since 483 was 483, checked in by Sam Hocevar, 11 years ago

lisp: move all array-related functions to the LispArray? struct.

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