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

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

lisp: properly manage user functions and reactivate garbage collector.

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