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

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

lisp: fix a memory leak in the grow stack objets and refactor the class.

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