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

Last change on this file since 636 was 636, checked in by Sam Hocevar, 7 years ago

lisp: merge the Lisp and LispGC classes and improve coding style.

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