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

Last change on this file since 502 was 502, checked in by Sam Hocevar, 10 years ago

lisp: remove debug information from the garbage collector.

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