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

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

lisp: always align the lisp allocator results, even on x86 or architectures
that have hardware realignment. Get rid of now useless bus_type.h.

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