source: abuse/branches/lol/src/lisp/lisp.cpp @ 732

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

build: SDL2 compilation fixes.

File size: 80.9 KB
Line 
1/*
2 *  Abuse - dark 2D side-scrolling platform game
3 *  Copyright (c) 1995 Crack dot Com
4 *  Copyright (c) 2005-2013 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 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/lisp.h"
26#include "lisp/lisp_gc.h"
27
28#include "symbols.h"
29#ifdef NO_LIBS
30#   include "fakelib.h"
31#else
32#   include "imlib/status.h"
33#   include "imlib/specs.h"
34#   include "imlib/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 = lol::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 = lol::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 = lol::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 = lol::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 = lol::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 = lol::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 = lol::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 = lol::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 = lol::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 = lol::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 (lol::abs(dx)>lol::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 (lol::abs(dx)>lol::abs(dy))
695    {
696      int32_t a=dx*29/lol::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=lol::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 (lol::abs(dx)>lol::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 (lol::abs(dx)>lol::abs(dy))
734    {
735      int32_t a=-dx*29/lol::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=lol::abs(dy)*29/lol::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 exists 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
1064static char token_buffer[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, token_buffer);
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, token_buffer))
1088        lerror(NULL, "unexpected end of program");
1089
1090  if (!strcmp(token_buffer, "nil"))
1091    return NULL;
1092  else if (toupper(token_buffer[0])=='T' && !token_buffer[1])
1093    return true_symbol;
1094  else if (token_buffer[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 (token_buffer[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 (token_buffer[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 (token_buffer[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, token_buffer))           // check for the end of the list
1141        lerror(NULL, "unexpected end of program");
1142      if (token_buffer[0]==')')
1143      {
1144                done=1;
1145                read_ltoken(code, token_buffer);                // read off the ')'
1146      }
1147      else
1148      {
1149                if (token_buffer[0]=='.' && !token_buffer[1])
1150                {
1151                  if (!first)
1152                    lerror(code, "token '.' not allowed here\n");
1153                  else
1154                  {
1155                    void *tmp;
1156                    read_ltoken(code, token_buffer);              // 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 r4(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 (token_buffer[0]==')')
1180    lerror(code, "mismatched )");
1181  else if (isdigit(token_buffer[0]) || (token_buffer[0]=='-' && isdigit(token_buffer[1])))
1182  {
1183    LNumber *num = LNumber::Create(0);
1184    sscanf(token_buffer, "%ld", &num->m_num);
1185    ret=num;
1186  } else if (token_buffer[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 (token_buffer[0]=='#')
1205  {
1206    if (token_buffer[1]=='\\')
1207    {
1208      read_ltoken(code, token_buffer);                   // read character name
1209      if (!strcmp(token_buffer, "newline"))
1210        ret = LChar::Create('\n');
1211      else if (!strcmp(token_buffer, "space"))
1212        ret = LChar::Create(' ');
1213      else
1214        ret = LChar::Create(token_buffer[0]);
1215    }
1216    else if (token_buffer[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", token_buffer);
1231      exit(0);
1232    }
1233  } else {
1234    ret = LSymbol::FindOrCreate(token_buffer);
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    Timer t;
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_taken += t.Get();
1497#endif
1498
1499    return ret;
1500}
1501
1502#ifdef L_PROFILE
1503void pro_print(bFILE *out, LSymbol *p)
1504{
1505  if (p)
1506  {
1507    pro_print(out, p->m_right);
1508    {
1509      char st[100];
1510      sprintf(st, "%20s %f\n", lstring_value(p->GetName()), p->time_taken);
1511      out->write(st, strlen(st));
1512    }
1513    pro_print(out, p->m_left);
1514  }
1515}
1516
1517void preport(char *fn)
1518{
1519  bFILE *fp=open_file("preport.out", "wb");
1520  pro_print(fp, LSymbol::root);
1521  delete fp;
1522}
1523#endif
1524
1525void *mapcar(void *arg_list)
1526{
1527  PtrRef ref1(arg_list);
1528  LObject *sym = CAR(arg_list)->Eval();
1529  switch ((short)item_type(sym))
1530  {
1531    case L_SYS_FUNCTION:
1532    case L_USER_FUNCTION:
1533    case L_SYMBOL:
1534      break;
1535    default:
1536    {
1537      sym->Print();
1538      lbreak(" is not a function\n");
1539      exit(0);
1540    }
1541  }
1542  int i, stop = 0, num_args = ((LList *)CDR(arg_list))->GetLength();
1543  if (!num_args) return 0;
1544
1545  void **arg_on=(void **)malloc(sizeof(void *)*num_args);
1546  LList *list_on=(LList *)CDR(arg_list);
1547  long old_ptr_son=PtrRef::stack.m_size;
1548
1549  for (i=0; i<num_args; i++)
1550  {
1551    arg_on[i] = (LList *)CAR(list_on)->Eval();
1552    PtrRef::stack.push(&arg_on[i]);
1553
1554    list_on=(LList *)CDR(list_on);
1555    if (!arg_on[i]) stop=1;
1556  }
1557
1558  if (stop)
1559  {
1560    free(arg_on);
1561    return NULL;
1562  }
1563
1564  LList *na_list=NULL, *return_list=NULL, *last_return=NULL;
1565
1566  do
1567  {
1568    na_list=NULL;          // create a cons list with all of the parameters for the function
1569
1570    LList *first=NULL;                       // save the start of the list
1571    for (i=0; !stop &&i<num_args; i++)
1572    {
1573      if (!na_list)
1574        first=na_list = LList::Create();
1575      else
1576      {
1577        na_list->m_cdr = (LObject *)LList::Create();
1578                na_list=(LList *)CDR(na_list);
1579      }
1580
1581
1582      if (arg_on[i])
1583      {
1584                na_list->m_car = (LObject *)CAR(arg_on[i]);
1585                arg_on[i]=(LList *)CDR(arg_on[i]);
1586      }
1587      else stop=1;
1588    }
1589    if (!stop)
1590    {
1591      LList *c = LList::Create();
1592      c->m_car = ((LSymbol *)sym)->EvalFunction(first);
1593      if (return_list)
1594        last_return->m_cdr=c;
1595      else
1596        return_list=c;
1597      last_return=c;
1598    }
1599  }
1600  while (!stop);
1601  PtrRef::stack.m_size=old_ptr_son;
1602
1603  free(arg_on);
1604  return return_list;
1605}
1606
1607void *concatenate(void *prog_list)
1608{
1609  void *el_list=CDR(prog_list);
1610  PtrRef ref1(prog_list), ref2(el_list);
1611  void *ret=NULL;
1612  void *rtype = CAR(prog_list)->Eval();
1613
1614  long len=0;                                // determin the length of the resulting string
1615  if (rtype==string_symbol)
1616  {
1617    int elements = ((LList *)el_list)->GetLength(); // see how many things we need to concat
1618    if (!elements) ret = LString::Create("");
1619    else
1620    {
1621      void **str_eval=(void **)malloc(elements*sizeof(void *));
1622      int i, old_ptr_stack_start=PtrRef::stack.m_size;
1623
1624      // evalaute all the strings and count their lengths
1625      for (i=0; i<elements; i++, el_list=CDR(el_list))
1626      {
1627        str_eval[i] = CAR(el_list)->Eval();
1628    PtrRef::stack.push(&str_eval[i]);
1629
1630    switch ((short)item_type(str_eval[i]))
1631    {
1632      case L_CONS_CELL :
1633      {
1634        LList *char_list=(LList *)str_eval[i];
1635        while (char_list)
1636        {
1637          if (item_type(CAR(char_list))==(ltype)L_CHARACTER)
1638            len++;
1639          else
1640          {
1641        ((LObject *)str_eval[i])->Print();
1642        lbreak(" is not a character\n");
1643        exit(0);
1644          }
1645          char_list=(LList *)CDR(char_list);
1646        }
1647      } break;
1648      case L_STRING : len+=strlen(lstring_value(str_eval[i])); break;
1649      default :
1650        ((LObject *)prog_list)->Print();
1651        lbreak("type not supported\n");
1652        exit(0);
1653      break;
1654
1655    }
1656      }
1657      LString *st = LString::Create(len+1);
1658      char *s=lstring_value(st);
1659
1660      // now add the string up into the new string
1661      for (i=0; i<elements; i++)
1662      {
1663    switch ((short)item_type(str_eval[i]))
1664    {
1665      case L_CONS_CELL :
1666      {
1667        LList *char_list=(LList *)str_eval[i];
1668        while (char_list)
1669        {
1670          if (item_type(CAR(char_list))==L_CHARACTER)
1671            *(s++)=((LChar *)CAR(char_list))->m_ch;
1672          char_list=(LList *)CDR(char_list);
1673        }
1674      } break;
1675      case L_STRING :
1676      {
1677        memcpy(s, lstring_value(str_eval[i]), strlen(lstring_value(str_eval[i])));
1678        s+=strlen(lstring_value(str_eval[i]));
1679      } break;
1680      default : ;     // already checked for, but make compiler happy
1681    }
1682      }
1683      free(str_eval);
1684      PtrRef::stack.m_size=old_ptr_stack_start;   // restore pointer GC stack
1685      *s=0;
1686      ret=st;
1687    }
1688  }
1689  else
1690  {
1691    ((LObject *)prog_list)->Print();
1692    lbreak("concat operation not supported, try 'string\n");
1693    exit(0);
1694  }
1695  return ret;
1696}
1697
1698
1699void *backquote_eval(void *args)
1700{
1701  if (item_type(args)!=L_CONS_CELL)
1702    return args;
1703  else if (args==NULL)
1704    return NULL;
1705  else if ((LSymbol *) (((LList *)args)->m_car)==comma_symbol)
1706    return CAR(CDR(args))->Eval();
1707  else
1708  {
1709    void *first=NULL, *last=NULL, *cur=NULL, *tmp;
1710    PtrRef ref1(first), ref2(last), ref3(cur), ref4(args);
1711    while (args)
1712    {
1713      if (item_type(args)==L_CONS_CELL)
1714      {
1715    if (CAR(args)==comma_symbol)               // dot list with a comma?
1716    {
1717      tmp = CAR(CDR(args))->Eval();
1718      ((LList *)last)->m_cdr = (LObject *)tmp;
1719      args=NULL;
1720    }
1721    else
1722    {
1723      cur = LList::Create();
1724      if (first)
1725        ((LList *)last)->m_cdr = (LObject *)cur;
1726      else
1727            first=cur;
1728      last=cur;
1729          tmp=backquote_eval(CAR(args));
1730          ((LList *)cur)->m_car = (LObject *)tmp;
1731       args=CDR(args);
1732    }
1733      } else
1734      {
1735    tmp=backquote_eval(args);
1736    ((LList *)last)->m_cdr = (LObject *)tmp;
1737    args=NULL;
1738      }
1739
1740    }
1741    return (void *)first;
1742  }
1743  return NULL;       // for stupid compiler messages
1744}
1745
1746/* PtrRef check: OK */
1747LObject *LSysFunction::EvalFunction(LList *arg_list)
1748{
1749    LObject *ret = NULL;
1750
1751    PtrRef ref1(arg_list);
1752
1753    switch (fun_number)
1754    {
1755    case SYS_FUNC_PRINT:
1756        while (arg_list)
1757        {
1758            ret = CAR(arg_list)->Eval();
1759            arg_list = (LList *)CDR(arg_list);
1760            ret->Print();
1761        }
1762        break;
1763    case SYS_FUNC_CAR:
1764        ret = lcar(CAR(arg_list)->Eval());
1765        break;
1766    case SYS_FUNC_CDR:
1767        ret = lcdr(CAR(arg_list)->Eval());
1768        break;
1769    case SYS_FUNC_LENGTH:
1770    {
1771        LObject *v = CAR(arg_list)->Eval();
1772        switch (item_type(v))
1773        {
1774        case L_STRING:
1775            ret = LNumber::Create(strlen(lstring_value(v)));
1776            break;
1777        case L_CONS_CELL:
1778            ret = LNumber::Create(((LList *)v)->GetLength());
1779            break;
1780        default:
1781            v->Print();
1782            lbreak("length : type not supported\n");
1783            break;
1784        }
1785        break;
1786    }
1787    case SYS_FUNC_LIST:
1788    {
1789        LList *cur = NULL, *last = NULL, *first = NULL;
1790        PtrRef r1(cur), r2(first), r3(last);
1791        while (arg_list)
1792        {
1793            cur = LList::Create();
1794            LObject *val = CAR(arg_list)->Eval();
1795            cur->m_car = val;
1796            if (last)
1797                last->m_cdr = cur;
1798            else
1799                first = cur;
1800            last = cur;
1801            arg_list = (LList *)CDR(arg_list);
1802        }
1803        ret = first;
1804        break;
1805    }
1806    case SYS_FUNC_CONS:
1807    {
1808        LList *c = LList::Create();
1809        PtrRef r1(c);
1810        LObject *val = CAR(arg_list)->Eval();
1811        c->m_car = val;
1812        val = CAR(CDR(arg_list))->Eval();
1813        c->m_cdr = val;
1814        ret = c;
1815        break;
1816    }
1817    case SYS_FUNC_QUOTE:
1818        ret = CAR(arg_list);
1819        break;
1820    case SYS_FUNC_EQ:
1821        l_user_stack.push(CAR(arg_list)->Eval());
1822        l_user_stack.push(CAR(CDR(arg_list))->Eval());
1823        ret = (LObject *)lisp_eq(l_user_stack.pop(1), l_user_stack.pop(1));
1824        break;
1825    case SYS_FUNC_EQUAL:
1826        l_user_stack.push(CAR(arg_list)->Eval());
1827        l_user_stack.push(CAR(CDR(arg_list))->Eval());
1828        ret = (LObject *)lisp_equal(l_user_stack.pop(1), l_user_stack.pop(1));
1829        break;
1830    case SYS_FUNC_PLUS:
1831    {
1832        int32_t sum = 0;
1833        while (arg_list)
1834        {
1835            sum += lnumber_value(CAR(arg_list)->Eval());
1836            arg_list = (LList *)CDR(arg_list);
1837        }
1838        ret = LNumber::Create(sum);
1839        break;
1840    }
1841    case SYS_FUNC_TIMES:
1842    {
1843        int32_t prod;
1844        LObject *first = CAR(arg_list)->Eval();
1845        PtrRef r1(first);
1846        if (arg_list && item_type(first) == L_FIXED_POINT)
1847        {
1848            prod = 1 << 16;
1849            do
1850            {
1851                prod = (prod >> 8) * (lfixed_point_value(first) >> 8);
1852                arg_list = (LList *)CDR(arg_list);
1853                if (arg_list)
1854                    first = CAR(arg_list)->Eval();
1855            } while (arg_list);
1856            ret = LFixedPoint::Create(prod);
1857        }
1858        else
1859        {
1860            prod = 1;
1861            do
1862            {
1863                prod *= lnumber_value(CAR(arg_list)->Eval());
1864                arg_list = (LList *)CDR(arg_list);
1865                if (arg_list)
1866                    first = CAR(arg_list)->Eval();
1867            } while (arg_list);
1868            ret = LNumber::Create(prod);
1869        }
1870        break;
1871    }
1872    case SYS_FUNC_SLASH:
1873    {
1874        int32_t quot = 0, first = 1;
1875        while (arg_list)
1876        {
1877            LObject *i = CAR(arg_list)->Eval();
1878            if (item_type(i) != L_NUMBER)
1879            {
1880                i->Print();
1881                lbreak("/ only defined for numbers, cannot divide ");
1882                exit(0);
1883            }
1884            else if (first)
1885            {
1886                quot = ((LNumber *)i)->m_num;
1887                first = 0;
1888            }
1889            else
1890                quot /= ((LNumber *)i)->m_num;
1891            arg_list = (LList *)CDR(arg_list);
1892        }
1893        ret = LNumber::Create(quot);
1894        break;
1895    }
1896    case SYS_FUNC_MINUS:
1897    {
1898        int32_t sub = lnumber_value(CAR(arg_list)->Eval());
1899        arg_list = (LList *)CDR(arg_list);
1900        while (arg_list)
1901        {
1902            sub -= lnumber_value(CAR(arg_list)->Eval());
1903            arg_list = (LList *)CDR(arg_list);
1904        }
1905        ret = LNumber::Create(sub);
1906        break;
1907    }
1908    case SYS_FUNC_IF:
1909        if (CAR(arg_list)->Eval())
1910            ret = CAR(CDR(arg_list))->Eval();
1911        else
1912        {
1913            arg_list = (LList *)CDR(CDR(arg_list)); // check for a else part
1914            if (arg_list)
1915                ret = CAR(arg_list)->Eval();
1916            else
1917                ret = NULL;
1918        }
1919        break;
1920    case SYS_FUNC_SETQ:
1921    case SYS_FUNC_SETF:
1922    {
1923        LObject *set_to = CAR(CDR(arg_list))->Eval(), *i = NULL;
1924        PtrRef r1(set_to), r2(i);
1925        i = CAR(arg_list);
1926
1927        ltype x = item_type(set_to);
1928        switch (item_type(i))
1929        {
1930        case L_SYMBOL:
1931            switch (item_type(((LSymbol *)i)->m_value))
1932            {
1933            case L_NUMBER:
1934                if (x == L_NUMBER && ((LSymbol *)i)->m_value != l_undefined)
1935                    ((LSymbol *)i)->SetNumber(lnumber_value(set_to));
1936                else
1937                    ((LSymbol *)i)->SetValue((LNumber *)set_to);
1938                break;
1939            case L_OBJECT_VAR:
1940                l_obj_set(((LObjectVar *)(((LSymbol *)i)->m_value))->m_index, set_to);
1941                break;
1942            default:
1943                ((LSymbol *)i)->SetValue((LObject *)set_to);
1944            }
1945            ret = ((LSymbol *)i)->m_value;
1946            break;
1947        case L_CONS_CELL:   // this better be an 'aref'
1948        {
1949#ifdef TYPE_CHECKING
1950            LObject *car = ((LList *)i)->m_car;
1951            if (car == car_symbol)
1952            {
1953                car = CAR(CDR(i))->Eval();
1954                if (!car || item_type(car) != L_CONS_CELL)
1955                {
1956                    car->Print();
1957                    lbreak("setq car : evaled object is not a cons cell\n");
1958                    exit(0);
1959                }
1960                ((LList *)car)->m_car = set_to;
1961            }
1962            else if (car == cdr_symbol)
1963            {
1964                car = CAR(CDR(i))->Eval();
1965                if (!car || item_type(car) != L_CONS_CELL)
1966                {
1967                    car->Print();
1968                    lbreak("setq cdr : evaled object is not a cons cell\n");
1969                    exit(0);
1970                }
1971                ((LList *)car)->m_cdr = set_to;
1972            }
1973            else if (car != aref_symbol)
1974            {
1975                lbreak("expected (aref, car, cdr, or symbol) in setq\n");
1976                exit(0);
1977            }
1978            else
1979            {
1980#endif
1981                LArray *a = (LArray *)CAR(CDR(i))->Eval();
1982                PtrRef r3(a);
1983#ifdef TYPE_CHECKING
1984                if (item_type(a) != L_1D_ARRAY)
1985                {
1986                    a->Print();
1987                    lbreak("is not an array (aref)\n");
1988                    exit(0);
1989                }
1990#endif
1991                int num = lnumber_value(CAR(CDR(CDR(i)))->Eval());
1992#ifdef TYPE_CHECKING
1993                if (num >= (int)a->m_len || num < 0)
1994                {
1995                    lbreak("aref : value of bounds (%d)\n", num);
1996                    exit(0);
1997                }
1998#endif
1999                a->GetData()[num] = set_to;
2000#ifdef TYPE_CHECKING
2001            }
2002#endif
2003            ret = set_to;
2004            break;
2005        }
2006        default:
2007            i->Print();
2008            lbreak("setq/setf only defined for symbols and arrays now..\n");
2009            exit(0);
2010            break;
2011        }
2012        break;
2013    }
2014    case SYS_FUNC_SYMBOL_LIST:
2015        ret = NULL;
2016        break;
2017    case SYS_FUNC_ASSOC:
2018    {
2019        LObject *item = CAR(arg_list)->Eval();
2020        PtrRef r1(item);
2021        LList *list = (LList *)CAR(CDR(arg_list))->Eval();
2022        PtrRef r2(list);
2023        ret = list->Assoc(item);
2024        break;
2025    }
2026    case SYS_FUNC_NOT:
2027    case SYS_FUNC_NULL:
2028        if (CAR(arg_list)->Eval() == NULL)
2029            ret = true_symbol;
2030        else
2031            ret = NULL;
2032        break;
2033    case SYS_FUNC_ACONS:
2034    {
2035        LObject *i1 = CAR(arg_list)->Eval();
2036        PtrRef r1(i1);
2037        LObject *i2 = CAR(CDR(arg_list))->Eval();
2038        PtrRef r2(i2);
2039        LList *cs = LList::Create();
2040        cs->m_car = i1;
2041        cs->m_cdr = i2;
2042        ret = cs;
2043        break;
2044    }
2045    case SYS_FUNC_PAIRLIS:
2046    {
2047        l_user_stack.push(CAR(arg_list)->Eval());
2048        arg_list = (LList *)CDR(arg_list);
2049        l_user_stack.push(CAR(arg_list)->Eval());
2050        arg_list = (LList *)CDR(arg_list);
2051        LObject *n3 = CAR(arg_list)->Eval();
2052        LObject *n2 = (LObject *)l_user_stack.pop(1);
2053        LObject *n1 = (LObject *)l_user_stack.pop(1);
2054        ret = (LObject *)pairlis(n1, n2, n3);
2055        break;
2056    }
2057    case SYS_FUNC_LET:
2058    {
2059        // make an a-list of new variable names and new values
2060        LObject *var_list = CAR(arg_list);
2061        LObject *block_list = CDR(arg_list);
2062        PtrRef r1(block_list), r2(var_list);
2063        long stack_start = l_user_stack.m_size;
2064
2065        while (var_list)
2066        {
2067            LObject *var_name = CAR(CAR(var_list)), *tmp;
2068#ifdef TYPE_CHECKING
2069            if (item_type(var_name) != L_SYMBOL)
2070            {
2071                var_name->Print();
2072                lbreak("should be a symbol (let)\n");
2073                exit(0);
2074            }
2075#endif
2076
2077            l_user_stack.push(((LSymbol *)var_name)->m_value);
2078            tmp = CAR(CDR(CAR(var_list)))->Eval();
2079            ((LSymbol *)var_name)->SetValue(tmp);
2080            var_list = CDR(var_list);
2081        }
2082
2083        // now evaluate each of the blocks with the new environment and
2084        // return value from the last block
2085        while (block_list)
2086        {
2087            ret = CAR(block_list)->Eval();
2088            block_list = CDR(block_list);
2089        }
2090
2091        long cur_stack = stack_start;
2092        var_list = CAR(arg_list); // now restore the old symbol values
2093        while (var_list)
2094        {
2095            LObject *var_name = CAR(CAR(var_list));
2096            ((LSymbol *)var_name)->SetValue((LObject *)l_user_stack.sdata[cur_stack++]);
2097            var_list = CDR(var_list);
2098        }
2099        l_user_stack.m_size = stack_start; // restore the stack
2100        break;
2101    }
2102    case SYS_FUNC_DEFUN:
2103    {
2104        LSymbol *symbol = (LSymbol *)CAR(arg_list);
2105        PtrRef r1(symbol);
2106#ifdef TYPE_CHECKING
2107        if (item_type(symbol) != L_SYMBOL)
2108        {
2109            symbol->Print();
2110            lbreak(" is not a symbol! (DEFUN)\n");
2111            exit(0);
2112        }
2113
2114        if (item_type(arg_list) != L_CONS_CELL)
2115        {
2116            arg_list->Print();
2117            lbreak("is not a lambda list (DEFUN)\n");
2118            exit(0);
2119        }
2120#endif
2121        LObject *block_list = CDR(CDR(arg_list));
2122
2123        LUserFunction *ufun = new_lisp_user_function((LList *)lcar(lcdr(arg_list)), (LList *)block_list);
2124        symbol->SetFunction(ufun);
2125        ret = symbol;
2126        break;
2127    }
2128    case SYS_FUNC_ATOM:
2129        ret = (LObject *)lisp_atom(CAR(arg_list)->Eval());
2130        break;
2131    case SYS_FUNC_AND:
2132    {
2133        LObject *l = arg_list;
2134        PtrRef r1(l);
2135        ret = true_symbol;
2136        while (l)
2137        {
2138            if (!CAR(l)->Eval())
2139            {
2140                ret = NULL;
2141                l = NULL; // short-circuit
2142            }
2143            else
2144                l = CDR(l);
2145        }
2146        break;
2147    }
2148    case SYS_FUNC_OR:
2149    {
2150        LObject *l = arg_list;
2151        PtrRef r1(l);
2152        ret = NULL;
2153        while (l)
2154        {
2155            if (CAR(l)->Eval())
2156            {
2157                ret = true_symbol;
2158                l = NULL; // short-circuit
2159            }
2160            else
2161                l = CDR(l);
2162        }
2163        break;
2164    }
2165    case SYS_FUNC_PROGN:
2166        ret = (LObject *)eval_block(arg_list);
2167        break;
2168    case SYS_FUNC_CONCATENATE:
2169        ret = (LObject *)concatenate(arg_list);
2170        break;
2171    case SYS_FUNC_CHAR_CODE:
2172    {
2173        LObject *i = CAR(arg_list)->Eval();
2174        PtrRef r1(i);
2175        ret = NULL;
2176        switch (item_type(i))
2177        {
2178        case L_CHARACTER:
2179            ret = LNumber::Create(((LChar *)i)->m_ch);
2180            break;
2181        case L_STRING:
2182            ret = LNumber::Create(*lstring_value(i));
2183            break;
2184        default:
2185            i->Print();
2186            lbreak(" is not character type\n");
2187            exit(0);
2188            break;
2189        }
2190        break;
2191    }
2192    case SYS_FUNC_CODE_CHAR:
2193    {
2194        LObject *i = CAR(arg_list)->Eval();
2195        PtrRef r1(i);
2196        if (item_type(i) != L_NUMBER)
2197        {
2198            i->Print();
2199            lbreak(" is not number type\n");
2200            exit(0);
2201        }
2202        ret = LChar::Create(((LNumber *)i)->m_num);
2203        break;
2204    }
2205    case SYS_FUNC_COND:
2206    {
2207        LList *block_list = (LList *)CAR(arg_list);
2208        PtrRef r1(block_list);
2209        ret = NULL;
2210        PtrRef r2(ret); // Required to protect from the last Eval call
2211        while (block_list)
2212        {
2213            if (lcar(CAR(block_list))->Eval())
2214                ret = CAR(CDR(CAR(block_list)))->Eval();
2215            block_list = (LList *)CDR(block_list);
2216        }
2217        break;
2218    }
2219    case SYS_FUNC_SELECT:
2220    {
2221        LObject *selector = CAR(arg_list)->Eval();
2222        LObject *sel = CDR(arg_list);
2223        PtrRef r1(selector), r2(sel);
2224        ret = NULL;
2225        PtrRef r3(ret); // Required to protect from the last Eval call
2226        while (sel)
2227        {
2228            if (lisp_equal(selector, CAR(CAR(sel))->Eval()))
2229            {
2230                sel = CDR(CAR(sel));
2231                while (sel)
2232                {
2233                    ret = CAR(sel)->Eval();
2234                    sel = CDR(sel);
2235                }
2236            }
2237            else
2238                sel = CDR(sel);
2239        }
2240        break;
2241    }
2242    case SYS_FUNC_FUNCTION:
2243        ret = ((LSymbol *)CAR(arg_list)->Eval())->GetFunction();
2244        break;
2245    case SYS_FUNC_MAPCAR:
2246        ret = (LObject *)mapcar(arg_list);
2247        break;
2248    case SYS_FUNC_FUNCALL:
2249    {
2250        LSymbol *n1 = (LSymbol *)CAR(arg_list)->Eval();
2251        ret = n1->EvalFunction(CDR(arg_list));
2252        break;
2253    }
2254    case SYS_FUNC_GT:
2255    {
2256        int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
2257        int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2258        ret = n1 > n2 ? true_symbol : NULL;
2259        break;
2260    }
2261    case SYS_FUNC_LT:
2262    {
2263        int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
2264        int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2265        ret = n1 < n2 ? true_symbol : NULL;
2266        break;
2267    }
2268    case SYS_FUNC_GE:
2269    {
2270        int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
2271        int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2272        ret = n1 >= n2 ? true_symbol : NULL;
2273        break;
2274    }
2275    case SYS_FUNC_LE:
2276    {
2277        int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
2278        int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2279        ret = n1 <= n2 ? true_symbol : NULL;
2280        break;
2281    }
2282    case SYS_FUNC_TMP_SPACE:
2283        tmp_space();
2284        ret = true_symbol;
2285        break;
2286    case SYS_FUNC_PERM_SPACE:
2287        perm_space();
2288        ret = true_symbol;
2289        break;
2290    case SYS_FUNC_SYMBOL_NAME:
2291    {
2292        LSymbol *symb = (LSymbol *)CAR(arg_list)->Eval();
2293#ifdef TYPE_CHECKING
2294        if (item_type(symb) != L_SYMBOL)
2295        {
2296            symb->Print();
2297            lbreak(" is not a symbol (symbol-name)\n");
2298            exit(0);
2299        }
2300#endif
2301        ret = symb->m_name;
2302        break;
2303    }
2304    case SYS_FUNC_TRACE:
2305        trace_level++;
2306        if (arg_list)
2307            trace_print_level = lnumber_value(CAR(arg_list)->Eval());
2308        ret = true_symbol;
2309        break;
2310    case SYS_FUNC_UNTRACE:
2311        if (trace_level > 0)
2312        {
2313            trace_level--;
2314            ret = true_symbol;
2315        }
2316        else
2317            ret = NULL;
2318        break;
2319    case SYS_FUNC_DIGSTR:
2320    {
2321        char tmp[50], *tp;
2322        int32_t num = lnumber_value(CAR(arg_list)->Eval());
2323        int32_t dig = lnumber_value(CAR(CDR(arg_list))->Eval());
2324        tp = tmp + 49;
2325        *(tp--) = 0;
2326        while (num)
2327        {
2328            *(tp--) = '0' + (num % 10);
2329            num /= 10;
2330            dig--;
2331        }
2332        while (dig--)
2333            *(tp--) = '0';
2334        ret = LString::Create(tp + 1);
2335        break;
2336    }
2337    case SYS_FUNC_LOCAL_LOAD:
2338    case SYS_FUNC_LOAD:
2339    case SYS_FUNC_COMPILE_FILE:
2340    {
2341        LObject *fn = CAR(arg_list)->Eval();
2342        PtrRef r1(fn);
2343        char *st = lstring_value(fn);
2344        bFILE *fp;
2345        if (fun_number == SYS_FUNC_LOCAL_LOAD)
2346        {
2347            // A special test for gamma.lsp
2348            if (strcmp(st, "gamma.lsp") == 0)
2349            {
2350                char *gammapath;
2351                gammapath = (char *)malloc(strlen(get_save_filename_prefix()) + 9 + 1);
2352                sprintf(gammapath, "%sgamma.lsp", get_save_filename_prefix());
2353                fp = new jFILE(gammapath, "rb");
2354                free(gammapath);
2355            }
2356            else
2357                fp = new jFILE(st, "rb");
2358        }
2359        else
2360            fp = open_file(st, "rb");
2361
2362        if (fp->open_failure())
2363        {
2364            delete fp;
2365            if (DEFINEDP(((LSymbol *)load_warning)->GetValue())
2366                 && ((LSymbol *)load_warning)->GetValue())
2367                dprintf("Warning : file %s does not exist\n", st);
2368            ret = NULL;
2369        }
2370        else
2371        {
2372            size_t l = fp->file_size();
2373            char *s = (char *)malloc(l + 1);
2374            if (!s)
2375            {
2376                printf("Malloc error in load_script\n");
2377                exit(0);
2378            }
2379
2380            fp->read(s, l);
2381            s[l] = 0;
2382            delete fp;
2383            char const *cs = s;
2384#ifndef NO_LIBS
2385            char msg[100];
2386            sprintf(msg, "(load \"%s\")", st);
2387            if (stat_man)
2388                stat_man->push(msg, NULL);
2389            crc_manager.GetFileNumber(st); // make sure this file gets crc'ed
2390#endif
2391            LObject *compiled_form = NULL;
2392            PtrRef r11(compiled_form);
2393            while (!end_of_program(cs))  // see if there is anything left to compile and run
2394            {
2395#ifndef NO_LIBS
2396                if (stat_man)
2397                    stat_man->update((cs - s) * 100 / l);
2398#endif
2399                void *m = LSpace::Tmp.Mark();
2400                compiled_form = LObject::Compile(cs);
2401                compiled_form->Eval();
2402                compiled_form = NULL;
2403                LSpace::Tmp.Restore(m);
2404            }
2405#ifndef NO_LIBS
2406            if (stat_man)
2407            {
2408                stat_man->update(100);
2409                stat_man->pop();
2410            }
2411#endif
2412            free(s);
2413            ret = fn;
2414        }
2415        break;
2416    }
2417    case SYS_FUNC_ABS:
2418        ret = LNumber::Create(lol::abs(lnumber_value(CAR(arg_list)->Eval())));
2419        break;
2420    case SYS_FUNC_MIN:
2421    {
2422        int32_t x = lnumber_value(CAR(arg_list)->Eval());
2423        int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
2424        ret = LNumber::Create(x < y ? x : y);
2425        break;
2426    }
2427    case SYS_FUNC_MAX:
2428    {
2429        int32_t x = lnumber_value(CAR(arg_list)->Eval());
2430        int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
2431        ret = LNumber::Create(x > y ? x : y);
2432        break;
2433    }
2434    case SYS_FUNC_BACKQUOTE:
2435        ret = (LObject *)backquote_eval(CAR(arg_list));
2436        break;
2437    case SYS_FUNC_COMMA:
2438        arg_list->Print();
2439        lbreak("comma is illegal outside of backquote\n");
2440        exit(0);
2441        break;
2442    case SYS_FUNC_NTH:
2443    {
2444        int32_t x = lnumber_value(CAR(arg_list)->Eval());
2445        ret = (LObject *)nth(x, CAR(CDR(arg_list))->Eval());
2446        break;
2447    }
2448    case SYS_FUNC_RESIZE_TMP:
2449        // Deprecated and useless
2450        break;
2451    case SYS_FUNC_RESIZE_PERM:
2452        // Deprecated and useless
2453        break;
2454    case SYS_FUNC_COS:
2455        ret = LFixedPoint::Create(lisp_cos(lnumber_value(CAR(arg_list)->Eval())));
2456        break;
2457    case SYS_FUNC_SIN:
2458        ret = LFixedPoint::Create(lisp_sin(lnumber_value(CAR(arg_list)->Eval())));
2459        break;
2460    case SYS_FUNC_ATAN2:
2461    {
2462        int32_t y = (lnumber_value(CAR(arg_list)->Eval()));
2463        int32_t x = (lnumber_value(CAR(CDR(arg_list))->Eval()));
2464        ret = LNumber::Create(lisp_atan2(y, x));
2465        break;
2466    }
2467    case SYS_FUNC_ENUM:
2468    {
2469        LSpace *sp = LSpace::Current;
2470        LSpace::Current = &LSpace::Perm;
2471        int32_t x = 0;
2472        while (arg_list)
2473        {
2474            LObject *sym = CAR(arg_list)->Eval();
2475            PtrRef r1(sym);
2476            switch (item_type(sym))
2477            {
2478            case L_SYMBOL:
2479            {
2480                LObject *tmp = LNumber::Create(x);
2481                ((LSymbol *)sym)->m_value = tmp;
2482                break;
2483            }
2484            case L_CONS_CELL:
2485            {
2486                LObject *s = CAR(sym)->Eval();
2487                PtrRef r2(s);
2488#ifdef TYPE_CHECKING
2489                if (item_type(s) != L_SYMBOL)
2490                {
2491                    arg_list->Print();
2492                    lbreak("expecting (symbol value) for enum\n");
2493                    exit(0);
2494                }
2495#endif
2496                x = lnumber_value(CAR(CDR(sym))->Eval());
2497                LObject *tmp = LNumber::Create(x);
2498                ((LSymbol *)sym)->m_value = tmp;
2499                break;
2500            }
2501            default:
2502                arg_list->Print();
2503                lbreak("expecting symbol or (symbol value) in enum\n");
2504                exit(0);
2505            }
2506            arg_list = (LList *)CDR(arg_list);
2507            x++;
2508        }
2509        LSpace::Current = sp;
2510        break;
2511    }
2512    case SYS_FUNC_QUIT:
2513        exit(0);
2514        break;
2515    case SYS_FUNC_EVAL:
2516        ret = CAR(arg_list)->Eval()->Eval();
2517        break;
2518    case SYS_FUNC_BREAK:
2519        lbreak("User break");
2520        break;
2521    case SYS_FUNC_MOD:
2522    {
2523        int32_t x = lnumber_value(CAR(arg_list)->Eval());
2524        int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
2525        if (y == 0)
2526        {
2527            lbreak("mod: division by zero\n");
2528            y = 1;
2529        }
2530        ret = LNumber::Create(x % y);
2531        break;
2532    }
2533#if 0
2534    case SYS_FUNC_WRITE_PROFILE:
2535    {
2536        char *fn = lstring_value(CAR(arg_list)->Eval());
2537        FILE *fp = fopen(fn, "wb");
2538        if (!fp)
2539            lbreak("could not open %s for writing", fn);
2540        else
2541        {
2542            for (void *s = symbol_list; s; s = CDR(s))
2543                fprintf(fp, "%8d  %s\n", ((LSymbol *)(CAR(s)))->call_counter,
2544                        lstring_value(((LSymbol *)(CAR(s)))->m_name));
2545            fclose(fp);
2546        }
2547        break;
2548    }
2549#endif
2550    case SYS_FUNC_FOR:
2551    {
2552        LSymbol *bind_var = (LSymbol *)CAR(arg_list);
2553        PtrRef r1(bind_var);
2554        if (item_type(bind_var) != L_SYMBOL)
2555        {
2556            lbreak("expecting for iterator to be a symbol\n");
2557            exit(1);
2558        }
2559        arg_list = (LList *)CDR(arg_list);
2560
2561        if (CAR(arg_list) != in_symbol)
2562        {
2563            lbreak("expecting in after 'for iterator'\n");
2564            exit(1);
2565        }
2566        arg_list = (LList *)CDR(arg_list);
2567
2568        LObject *ilist = CAR(arg_list)->Eval();
2569        PtrRef r2(ilist);
2570        arg_list = (LList *)CDR(arg_list);
2571
2572        if (CAR(arg_list) != do_symbol)
2573        {
2574            lbreak("expecting do after 'for iterator in list'\n");
2575            exit(1);
2576        }
2577        arg_list = (LList *)CDR(arg_list);
2578
2579        LObject *block = NULL;
2580        PtrRef r3(block);
2581        PtrRef r4(ret); // Required to protect from the last SetValue call
2582        l_user_stack.push(bind_var->GetValue());  // save old symbol value
2583        while (ilist)
2584        {
2585            bind_var->SetValue((LObject *)CAR(ilist));
2586            for (block = arg_list; block; block = CDR(block))
2587                ret = CAR(block)->Eval();
2588            ilist = CDR(ilist);
2589        }
2590        bind_var->SetValue((LObject *)l_user_stack.pop(1)); // restore value
2591        break;
2592    }
2593    case SYS_FUNC_OPEN_FILE:
2594    {
2595        LObject *str1 = CAR(arg_list)->Eval();
2596        PtrRef r1(str1);
2597        LObject *str2 = CAR(CDR(arg_list))->Eval();
2598
2599        bFILE *old_file = current_print_file;
2600        current_print_file = open_file(lstring_value(str1),
2601                                       lstring_value(str2));
2602
2603        if (!current_print_file->open_failure())
2604        {
2605            while (arg_list)
2606            {
2607                ret = CAR(arg_list)->Eval();
2608                arg_list = (LList *)CDR(arg_list);
2609            }
2610        }
2611        delete current_print_file;
2612        current_print_file = old_file;
2613        break;
2614    }
2615    case SYS_FUNC_BIT_AND:
2616    {
2617        int32_t first = lnumber_value(CAR(arg_list)->Eval());
2618        arg_list = (LList *)CDR(arg_list);
2619        while (arg_list)
2620        {
2621            first &= lnumber_value(CAR(arg_list)->Eval());
2622            arg_list = (LList *)CDR(arg_list);
2623        }
2624        ret = LNumber::Create(first);
2625        break;
2626    }
2627    case SYS_FUNC_BIT_OR:
2628    {
2629        int32_t first = lnumber_value(CAR(arg_list)->Eval());
2630        arg_list = (LList *)CDR(arg_list);
2631        while (arg_list)
2632        {
2633            first |= lnumber_value(CAR(arg_list)->Eval());
2634            arg_list = (LList *)CDR(arg_list);
2635        }
2636        ret = LNumber::Create(first);
2637        break;
2638    }
2639    case SYS_FUNC_BIT_XOR:
2640    {
2641        int32_t first = lnumber_value(CAR(arg_list)->Eval());
2642        arg_list = (LList *)CDR(arg_list);
2643        while (arg_list)
2644        {
2645            first ^= lnumber_value(CAR(arg_list)->Eval());
2646            arg_list = (LList *)CDR(arg_list);
2647        }
2648        ret = LNumber::Create(first);
2649        break;
2650    }
2651    case SYS_FUNC_MAKE_ARRAY:
2652    {
2653        int32_t l = lnumber_value(CAR(arg_list)->Eval());
2654        if (l >= (2 << 16) || l <= 0)
2655        {
2656            lbreak("bad array size %d\n", l);
2657            exit(0);
2658        }
2659        ret = LArray::Create(l, CDR(arg_list));
2660        break;
2661    }
2662    case SYS_FUNC_AREF:
2663    {
2664        int32_t x = lnumber_value(CAR(CDR(arg_list))->Eval());
2665        ret = ((LArray *)CAR(arg_list)->Eval())->Get(x);
2666        break;
2667    }
2668    case SYS_FUNC_IF_1PROGN:
2669        if (CAR(arg_list)->Eval())
2670            ret = (LObject *)eval_block(CAR(CDR(arg_list)));
2671        else
2672            ret = CAR(CDR(CDR(arg_list)))->Eval();
2673        break;
2674    case SYS_FUNC_IF_2PROGN:
2675        if (CAR(arg_list)->Eval())
2676            ret = CAR(CDR(arg_list))->Eval();
2677        else
2678            ret = (LObject *)eval_block(CAR(CDR(CDR(arg_list))));
2679
2680        break;
2681    case SYS_FUNC_IF_12PROGN:
2682        if (CAR(arg_list)->Eval())
2683            ret = (LObject *)eval_block(CAR(CDR(arg_list)));
2684        else
2685            ret = (LObject *)eval_block(CAR(CDR(CDR(arg_list))));
2686        break;
2687    case SYS_FUNC_EQ0:
2688    {
2689        LObject *v = CAR(arg_list)->Eval();
2690        if (item_type(v) != L_NUMBER || (((LNumber *)v)->m_num != 0))
2691            ret = NULL;
2692        else
2693            ret = true_symbol;
2694        break;
2695    }
2696    case SYS_FUNC_PREPORT:
2697    {
2698#ifdef L_PROFILE
2699        char *s = lstring_value(CAR(arg_list)->Eval());
2700        preport(s);
2701#endif
2702        break;
2703    }
2704    case SYS_FUNC_SEARCH:
2705    {
2706        LObject *arg1 = CAR(arg_list)->Eval();
2707        PtrRef r1(arg1); // protect this reference
2708        arg_list = (LList *)CDR(arg_list);
2709        char *haystack = lstring_value(CAR(arg_list)->Eval());
2710        char *needle = lstring_value(arg1);
2711
2712        char *find = strstr(haystack, needle);
2713        ret = find ? LNumber::Create(find - haystack) : NULL;
2714        break;
2715    }
2716    case SYS_FUNC_ELT:
2717    {
2718        LObject *arg1 = CAR(arg_list)->Eval();
2719        PtrRef r1(arg1); // protect this reference
2720        arg_list = (LList *)CDR(arg_list);
2721        int32_t x = lnumber_value(CAR(arg_list)->Eval());
2722        char *st = lstring_value(arg1);
2723        if (x < 0 || x >= (int32_t)strlen(st))
2724        {
2725            lbreak("elt: out of range of string\n");
2726            ret = NULL;
2727        }
2728        else
2729            ret = LChar::Create(st[x]);
2730        break;
2731    }
2732    case SYS_FUNC_LISTP:
2733    {
2734        LObject *tmp = CAR(arg_list)->Eval();
2735        ltype t = item_type(tmp);
2736        ret = (t == L_CONS_CELL) ? true_symbol : NULL;
2737        break;
2738    }
2739    case SYS_FUNC_NUMBERP:
2740    {
2741        LObject *tmp = CAR(arg_list)->Eval();
2742        ltype t = item_type(tmp);
2743        ret = (t == L_NUMBER || t == L_FIXED_POINT) ? true_symbol : NULL;
2744        break;
2745    }
2746    case SYS_FUNC_DO:
2747    {
2748        LObject *init_var = CAR(arg_list);
2749        PtrRef r1(init_var);
2750        int ustack_start = l_user_stack.m_size; // restore stack at end
2751        LSymbol *sym = NULL;
2752        PtrRef r2(sym);
2753
2754        // check to make sure iter vars are symbol and push old values
2755        for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2756        {
2757            sym = (LSymbol *)CAR(CAR(init_var));
2758            if (item_type(sym) != L_SYMBOL)
2759            {
2760                lbreak("expecting symbol name for iteration var\n");
2761                exit(0);
2762            }
2763            l_user_stack.push(sym->GetValue());
2764        }
2765
2766        void **do_evaled = l_user_stack.sdata + l_user_stack.m_size;
2767        // push all of the init forms, so we can set the symbol
2768        for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2769            l_user_stack.push(CAR(CDR(CAR((init_var))))->Eval());
2770
2771        // now set all the symbols
2772        for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2773        {
2774            sym = (LSymbol *)CAR(CAR(init_var));
2775            sym->SetValue((LObject *)*do_evaled);
2776            do_evaled++;
2777        }
2778
2779        for (int i = 0; !i; ) // set i to 1 when terminate conditions are met
2780        {
2781            i = CAR(CAR(CDR(arg_list)))->Eval() != NULL;
2782            if (!i)
2783            {
2784                eval_block(CDR(CDR(arg_list)));
2785                for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2786                    CAR(CDR(CDR(CAR(init_var))))->Eval();
2787            }
2788        }
2789
2790        ret = CAR(CDR(CAR(CDR(arg_list))))->Eval();
2791
2792        // restore old values for symbols
2793        do_evaled = l_user_stack.sdata + ustack_start;
2794        for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2795        {
2796            sym = (LSymbol *)CAR(CAR(init_var));
2797            sym->SetValue((LObject *)*do_evaled);
2798            do_evaled++;
2799        }
2800
2801        l_user_stack.m_size = ustack_start;
2802        break;
2803    }
2804    case SYS_FUNC_GC:
2805        Lisp::CollectSpace(LSpace::Current, 0);
2806        break;
2807    case SYS_FUNC_SCHAR:
2808    {
2809        char *s = lstring_value(CAR(arg_list)->Eval());
2810        arg_list = (LList *)CDR(arg_list);
2811        int32_t x = lnumber_value(CAR(arg_list)->Eval());
2812
2813        if (x < 0 || x >= (int32_t)strlen(s))
2814        {
2815            lbreak("SCHAR: index %d out of bounds\n", x);
2816            exit(0);
2817        }
2818        ret = LChar::Create(s[x]);
2819        break;
2820    }
2821    case SYS_FUNC_SYMBOLP:
2822    {
2823        LObject *tmp = CAR(arg_list)->Eval();
2824        ret = (item_type(tmp) == L_SYMBOL) ? true_symbol : NULL;
2825        break;
2826    }
2827    case SYS_FUNC_NUM2STR:
2828    {
2829        char str[20];
2830        sprintf(str, "%ld", (long int)lnumber_value(CAR(arg_list)->Eval()));
2831        ret = LString::Create(str);
2832        break;
2833    }
2834    case SYS_FUNC_NCONC:
2835    {
2836        LObject *l1 = CAR(arg_list)->Eval();
2837        PtrRef r1(l1);
2838        arg_list = (LList *)CDR(arg_list);
2839        LObject *first = l1, *next;
2840        PtrRef r2(first);
2841
2842        if (!l1)
2843        {
2844            l1 = first = CAR(arg_list)->Eval();
2845            arg_list = (LList *)CDR(arg_list);
2846        }
2847
2848        if (item_type(l1) != L_CONS_CELL)
2849        {
2850            l1->Print();
2851            lbreak("first arg should be a list\n");
2852        }
2853
2854        do
2855        {
2856            next = l1;
2857            while (next)
2858            {
2859                l1 = next;
2860                next = lcdr(next);
2861            }
2862            LObject *tmp = CAR(arg_list)->Eval();
2863            ((LList *)l1)->m_cdr = tmp;
2864            arg_list = (LList *)CDR(arg_list);
2865        } while (arg_list);
2866        ret = first;
2867        break;
2868    }
2869    case SYS_FUNC_FIRST:
2870        ret = CAR(CAR(arg_list)->Eval());
2871        break;
2872    case SYS_FUNC_SECOND:
2873        ret = CAR(CDR(CAR(arg_list)->Eval()));
2874        break;
2875    case SYS_FUNC_THIRD:
2876        ret = CAR(CDR(CDR(CAR(arg_list)->Eval())));
2877        break;
2878    case SYS_FUNC_FOURTH:
2879        ret = CAR(CDR(CDR(CDR(CAR(arg_list)->Eval()))));
2880        break;
2881    case SYS_FUNC_FIFTH:
2882        ret = CAR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))));
2883        break;
2884    case SYS_FUNC_SIXTH:
2885        ret = CAR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))));
2886        break;
2887    case SYS_FUNC_SEVENTH:
2888        ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))));
2889        break;
2890    case SYS_FUNC_EIGHTH:
2891        ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))));
2892        break;
2893    case SYS_FUNC_NINTH:
2894        ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))))));
2895        break;
2896    case SYS_FUNC_TENTH:
2897        ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))))));
2898        break;
2899    case SYS_FUNC_SUBSTR:
2900    {
2901        int32_t x1 = lnumber_value(CAR(arg_list)->Eval());
2902        int32_t x2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2903        LObject *st = CAR(CAR(CDR(arg_list)))->Eval();
2904        PtrRef r1(st);
2905
2906        if (x1 < 0 || x1 > x2 || x2 >= (int32_t)strlen(lstring_value(st)))
2907            lbreak("substr: bad x1 or x2 value");
2908
2909        LString *s = LString::Create(x2 - x1 + 2);
2910        if (x2 - x1)
2911            memcpy(lstring_value(s), lstring_value(st) + x1, x2 - x1 + 1);
2912
2913        lstring_value(s)[x2 - x1 + 1] = 0;
2914        ret = s;
2915        break;
2916    }
2917    case 99:
2918    {
2919        LObject *r = NULL, *rstart = NULL;
2920        PtrRef r1(r), r2(rstart);
2921        while (arg_list)
2922        {
2923            LObject *q = CAR(arg_list)->Eval();
2924            if (!rstart)
2925                rstart = q;
2926            while (r && CDR(r))
2927                r = CDR(r);
2928            CDR(r) = q;
2929            arg_list = (LList *)CDR(arg_list);
2930        }
2931        ret = rstart;
2932        break;
2933    }
2934    default:
2935        dprintf("Undefined system function number %d\n", fun_number);
2936        break;
2937    }
2938
2939    return ret;
2940}
2941
2942void tmp_space()
2943{
2944    LSpace::Current = &LSpace::Tmp;
2945}
2946
2947void perm_space()
2948{
2949    LSpace::Current = &LSpace::Perm;
2950}
2951
2952/* PtrRef check: OK */
2953LObject *LSymbol::EvalUserFunction(LList *arg_list)
2954{
2955    LObject *ret = NULL;
2956    PtrRef ref1(ret);
2957
2958#ifdef TYPE_CHECKING
2959    if (item_type(this) != L_SYMBOL)
2960    {
2961        Print();
2962        lbreak("EVAL : is not a function name (not symbol either)");
2963        exit(0);
2964    }
2965#endif
2966#ifdef L_PROFILE
2967    Timer t;
2968#endif
2969
2970    LUserFunction *fun = (LUserFunction *)m_function;
2971
2972#ifdef TYPE_CHECKING
2973    if (item_type(fun) != L_USER_FUNCTION)
2974    {
2975        Print();
2976        lbreak("is not a user defined function\n");
2977    }
2978#endif
2979
2980    LList *fun_arg_list = fun->arg_list;
2981    LList *block_list = fun->block_list;
2982    PtrRef r9(block_list), r10(fun_arg_list);
2983
2984    // mark the start start, so we can restore when done
2985    long stack_start = l_user_stack.m_size;
2986
2987    // first push all of the old symbol values
2988    LObject *f_arg = NULL;
2989    PtrRef r18(f_arg);
2990    PtrRef r19(arg_list);
2991
2992    for (f_arg = fun_arg_list; f_arg; f_arg = CDR(f_arg))
2993    {
2994        LSymbol *s = (LSymbol *)CAR(f_arg);
2995        l_user_stack.push(s->m_value);
2996    }
2997
2998    // open block so that local vars aren't saved on the stack
2999    {
3000        int new_start = l_user_stack.m_size;
3001        int i = new_start;
3002        // now push all the values we wish to gather
3003        for (f_arg = fun_arg_list; f_arg; f_arg = CDR(f_arg))
3004        {
3005            if (!arg_list)
3006            {
3007                Print();
3008                lbreak("too few parameter to function\n");
3009                exit(0);
3010            }
3011            l_user_stack.push(CAR(arg_list)->Eval());
3012            arg_list = (LList *)CDR(arg_list);
3013        }
3014
3015        // now store all the values and put them into the symbols
3016        for (f_arg = fun_arg_list; f_arg; f_arg = CDR(f_arg))
3017            ((LSymbol *)CAR(f_arg))->SetValue((LObject *)l_user_stack.sdata[i++]);
3018
3019        l_user_stack.m_size = new_start;
3020    }
3021
3022    if (f_arg)
3023    {
3024        Print();
3025        lbreak("too many parameter to function\n");
3026        exit(0);
3027    }
3028
3029    // now evaluate the function block
3030    while (block_list)
3031    {
3032        ret = CAR(block_list)->Eval();
3033        block_list = (LList *)CDR(block_list);
3034    }
3035
3036    long cur_stack = stack_start;
3037    for (f_arg = fun_arg_list; f_arg; f_arg = CDR(f_arg))
3038        ((LSymbol *)CAR(f_arg))->SetValue((LObject *)l_user_stack.sdata[cur_stack++]);
3039
3040    l_user_stack.m_size = stack_start;
3041
3042#ifdef L_PROFILE
3043    sym->time_taken += t.Get();
3044#endif
3045
3046    return ret;
3047}
3048
3049/* PtrRef check: OK */
3050LObject *LObject::Eval()
3051{
3052    PtrRef ref1(this);
3053
3054    maxevaldepth = lol::max(maxevaldepth, ++evaldepth);
3055
3056    int tstart = trace_level;
3057
3058    if (trace_level)
3059    {
3060        if (trace_level <= trace_print_level)
3061        {
3062            dprintf("%d (%d, %d, %d) TRACE : ", trace_level,
3063                    LSpace::Perm.GetFree(), LSpace::Tmp.GetFree(),
3064                    PtrRef::stack.m_size);
3065            Print();
3066            dprintf("\n");
3067        }
3068        trace_level++;
3069    }
3070
3071    LObject *ret = NULL;
3072
3073    if (this)
3074    {
3075        switch (item_type(this))
3076        {
3077        case L_BAD_CELL:
3078            lbreak("error: eval on a bad cell\n");
3079            exit(0);
3080            break;
3081        case L_CHARACTER:
3082        case L_STRING:
3083        case L_NUMBER:
3084        case L_POINTER:
3085        case L_FIXED_POINT:
3086            ret = this;
3087            break;
3088        case L_SYMBOL:
3089            if (this == true_symbol)
3090                ret = this;
3091            else
3092            {
3093                ret = ((LSymbol *)this)->GetValue();
3094                if (item_type(ret) == L_OBJECT_VAR)
3095                    ret = (LObject *)l_obj_get(((LObjectVar *)ret)->m_index);
3096            }
3097            break;
3098        case L_CONS_CELL:
3099            ret = ((LSymbol *)CAR(this))->EvalFunction(CDR(this));
3100            break;
3101        default :
3102            fprintf(stderr, "shouldn't happen\n");
3103            break;
3104        }
3105    }
3106
3107    if (tstart)
3108    {
3109        trace_level--;
3110        if (trace_level <= trace_print_level)
3111            dprintf("%d (%d, %d, %d) TRACE ==> ", trace_level,
3112                    LSpace::Perm.GetFree(), LSpace::Tmp.GetFree(),
3113                    PtrRef::stack.m_size);
3114        ret->Print();
3115        dprintf("\n");
3116    }
3117
3118/*  l_user_stack.push(ret);
3119  Lisp::CollectSpace(&LSpace::Perm);
3120  ret=l_user_stack.pop(1);  */
3121    --evaldepth;
3122
3123    return ret;
3124}
3125
3126void Lisp::Init()
3127{
3128    LSymbol::root = NULL;
3129    total_user_functions = 0;
3130
3131    LSpace::Tmp.m_free = LSpace::Tmp.m_data = (uint8_t *)malloc(0x1000);
3132    LSpace::Tmp.m_size = 0x1000;
3133    LSpace::Tmp.m_name = "temporary space";
3134
3135    LSpace::Perm.m_free = LSpace::Perm.m_data = (uint8_t *)malloc(0x1000);
3136    LSpace::Perm.m_size = 0x1000;
3137    LSpace::Perm.m_name = "permanent space";
3138
3139    LSpace::Gc.m_name = "garbage space";
3140
3141    LSpace::Current = &LSpace::Perm;
3142
3143    InitConstants();
3144
3145    for(size_t i = 0; i < sizeof(sys_funcs) / sizeof(*sys_funcs); i++)
3146        add_sys_function(sys_funcs[i].name,
3147                         sys_funcs[i].min_args, sys_funcs[i].max_args, i);
3148    clisp_init();
3149    LSpace::Current = &LSpace::Tmp;
3150    dprintf("Lisp: %d symbols defined, %d system functions, "
3151            "%d pre-compiled functions\n", LSymbol::count,
3152            sizeof(sys_funcs) / sizeof(*sys_funcs), total_user_functions);
3153}
3154
3155void Lisp::Uninit()
3156{
3157    free(LSpace::Tmp.m_data);
3158    free(LSpace::Perm.m_data);
3159    DeleteAllSymbols(LSymbol::root);
3160    LSymbol::root = NULL;
3161    LSymbol::count = 0;
3162}
3163
3164void LSpace::Clear()
3165{
3166    m_free = m_data;
3167}
3168
3169LString *LSymbol::GetName()
3170{
3171#ifdef TYPE_CHECKING
3172    if (item_type(this) != L_SYMBOL)
3173    {
3174        Print();
3175        lbreak("is not a symbol\n");
3176        exit(0);
3177    }
3178#endif
3179    return m_name;
3180}
3181
3182void LSymbol::SetNumber(long num)
3183{
3184#ifdef TYPE_CHECKING
3185    if (item_type(this) != L_SYMBOL)
3186    {
3187        Print();
3188        lbreak("is not a symbol\n");
3189        exit(0);
3190    }
3191#endif
3192    if (m_value != l_undefined && item_type(m_value) == L_NUMBER)
3193        ((LNumber *)m_value)->m_num = num;
3194    else
3195        m_value = LNumber::Create(num);
3196}
3197
3198void LSymbol::SetValue(LObject *val)
3199{
3200#ifdef TYPE_CHECKING
3201    if (item_type(this) != L_SYMBOL)
3202    {
3203        Print();
3204        lbreak("is not a symbol\n");
3205        exit(0);
3206    }
3207#endif
3208    m_value = val;
3209}
3210
3211LObject *LSymbol::GetFunction()
3212{
3213#ifdef TYPE_CHECKING
3214    if (item_type(this) != L_SYMBOL)
3215    {
3216        Print();
3217        lbreak("is not a symbol\n");
3218        exit(0);
3219    }
3220#endif
3221    return m_function;
3222}
3223
3224LObject *LSymbol::GetValue()
3225{
3226#ifdef TYPE_CHECKING
3227    if (item_type(this) != L_SYMBOL)
3228    {
3229        Print();
3230        lbreak("is not a symbol\n");
3231        exit(0);
3232    }
3233#endif
3234    return m_value;
3235}
3236
Note: See TracBrowser for help on using the repository browser.