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

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

lisp: fix a confusion in the `assoc' lisp implementation usage, and
make it a LList method to avoid future breakage.

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