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

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

imlib: use vec2i for image::size and unroll all necessary changes
everywhere else in the code.

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