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

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

lisp: implement LSymbol::EvalUserFunction? and ensure all local pointers
are protected against collection.

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