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

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

lisp: refactor Lisp spaces so that they are real objects, and get rid
of the unused USER_SPACE.

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