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

Last change on this file since 489 was 489, checked in by Sam Hocevar, 10 years ago

lisp: no LispSymbol? members are anonymous pointers any longer.

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