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

Last change on this file since 563 was 563, checked in by Sam Hocevar, 8 years ago

lisp: minor refactoring.

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