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

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

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

File size: 78.0 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 enviroment\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_refrence->");
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
1431void *eval_sys_function(LSysFunction *fun, void *arg_list);
1432
1433LObject *LSymbol::EvalFunction(void *arg_list)
1434{
1435#ifdef TYPE_CHECKING
1436    int args, req_min, req_max;
1437    if (item_type(this) != L_SYMBOL)
1438    {
1439        Print();
1440        lbreak("EVAL: is not a function name (not symbol either)");
1441        exit(0);
1442    }
1443#endif
1444
1445    LObject *fun = function;
1446    PtrRef ref2(fun);
1447    PtrRef ref3(arg_list);
1448
1449    // make sure the arguments given to the function are the correct number
1450    ltype t = item_type(fun);
1451
1452#ifdef TYPE_CHECKING
1453    switch (t)
1454    {
1455    case L_SYS_FUNCTION:
1456    case L_C_FUNCTION:
1457    case L_C_BOOL:
1458    case L_L_FUNCTION:
1459        req_min = ((LSysFunction *)fun)->min_args;
1460        req_max = ((LSysFunction *)fun)->max_args;
1461        break;
1462    case L_USER_FUNCTION:
1463        return (LObject *)eval_user_fun(this, arg_list);
1464    default:
1465        Print();
1466        lbreak(" is not a function name");
1467        exit(0);
1468        break;
1469    }
1470
1471    if (req_min != -1)
1472    {
1473        void *a = arg_list;
1474        for (args = 0; a; a = CDR(a))
1475            args++; // count number of parameters
1476
1477        if (args < req_min)
1478        {
1479            ((LObject *)arg_list)->Print();
1480            name->Print();
1481            lbreak("\nToo few parameters to function\n");
1482            exit(0);
1483        }
1484        else if (req_max != -1 && args > req_max)
1485        {
1486            ((LObject *)arg_list)->Print();
1487            name->Print();
1488            lbreak("\nToo many parameters to function\n");
1489            exit(0);
1490        }
1491    }
1492#endif
1493
1494#ifdef L_PROFILE
1495    time_marker start;
1496#endif
1497
1498    LObject *ret = NULL;
1499
1500    switch (t)
1501    {
1502    case L_SYS_FUNCTION:
1503        ret = (LObject *)eval_sys_function(((LSysFunction *)fun), arg_list);
1504        break;
1505    case L_L_FUNCTION:
1506        ret = (LObject *)l_caller(((LSysFunction *)fun)->fun_number, arg_list);
1507        break;
1508    case L_USER_FUNCTION:
1509        return (LObject *)eval_user_fun(this, arg_list);
1510    case L_C_FUNCTION:
1511    case L_C_BOOL:
1512    {
1513        LList *first = NULL, *cur = NULL;
1514        PtrRef r1(first), r2(cur), r3(arg_list);
1515        while (arg_list)
1516        {
1517            LList *tmp = LList::Create();
1518            if (first)
1519                cur->cdr = tmp;
1520            else
1521                first = tmp;
1522            cur = tmp;
1523
1524            LObject *val = CAR(arg_list)->Eval();
1525            ((LList *)cur)->car = val;
1526            arg_list = lcdr(arg_list);
1527        }
1528        if (t == L_C_FUNCTION)
1529            ret = LNumber::Create(c_caller(((LSysFunction *)fun)->fun_number, first));
1530        else if (c_caller(((LSysFunction *)fun)->fun_number, first))
1531            ret = true_symbol;
1532        else
1533            ret = NULL;
1534        break;
1535    }
1536    default:
1537        fprintf(stderr, "not a fun, shouldn't happen\n");
1538    }
1539
1540#ifdef L_PROFILE
1541    time_marker end;
1542    time_taken += end.diff_time(&start);
1543#endif
1544
1545    return ret;
1546}
1547
1548#ifdef L_PROFILE
1549void pro_print(bFILE *out, LSymbol *p)
1550{
1551  if (p)
1552  {
1553    pro_print(out, p->right);
1554    {
1555      char st[100];
1556      sprintf(st, "%20s %f\n", lstring_value(p->GetName()), p->time_taken);
1557      out->write(st, strlen(st));
1558    }
1559    pro_print(out, p->left);
1560  }
1561}
1562
1563void preport(char *fn)
1564{
1565  bFILE *fp=open_file("preport.out", "wb");
1566  pro_print(fp, LSymbol::root);
1567  delete fp;
1568}
1569#endif
1570
1571void *mapcar(void *arg_list)
1572{
1573  PtrRef ref1(arg_list);
1574  LObject *sym = CAR(arg_list)->Eval();
1575  switch ((short)item_type(sym))
1576  {
1577    case L_SYS_FUNCTION:
1578    case L_USER_FUNCTION:
1579    case L_SYMBOL:
1580      break;
1581    default:
1582    {
1583      sym->Print();
1584      lbreak(" is not a function\n");
1585      exit(0);
1586    }
1587  }
1588  int i, stop = 0, num_args = ((LList *)CDR(arg_list))->GetLength();
1589  if (!num_args) return 0;
1590
1591  void **arg_on=(void **)malloc(sizeof(void *)*num_args);
1592  LList *list_on=(LList *)CDR(arg_list);
1593  long old_ptr_son=PtrRef::stack.son;
1594
1595  for (i=0; i<num_args; i++)
1596  {
1597    arg_on[i] = (LList *)CAR(list_on)->Eval();
1598    PtrRef::stack.push(&arg_on[i]);
1599
1600    list_on=(LList *)CDR(list_on);
1601    if (!arg_on[i]) stop=1;
1602  }
1603
1604  if (stop)
1605  {
1606    free(arg_on);
1607    return NULL;
1608  }
1609
1610  LList *na_list=NULL, *return_list=NULL, *last_return=NULL;
1611
1612  do
1613  {
1614    na_list=NULL;          // create a cons list with all of the parameters for the function
1615
1616    LList *first=NULL;                       // save the start of the list
1617    for (i=0; !stop &&i<num_args; i++)
1618    {
1619      if (!na_list)
1620        first=na_list = LList::Create();
1621      else
1622      {
1623        na_list->cdr = (LObject *)LList::Create();
1624                na_list=(LList *)CDR(na_list);
1625      }
1626
1627
1628      if (arg_on[i])
1629      {
1630                na_list->car = (LObject *)CAR(arg_on[i]);
1631                arg_on[i]=(LList *)CDR(arg_on[i]);
1632      }
1633      else stop=1;
1634    }
1635    if (!stop)
1636    {
1637      LList *c = LList::Create();
1638      c->car = ((LSymbol *)sym)->EvalFunction(first);
1639      if (return_list)
1640        last_return->cdr=c;
1641      else
1642        return_list=c;
1643      last_return=c;
1644    }
1645  }
1646  while (!stop);
1647  PtrRef::stack.son=old_ptr_son;
1648
1649  free(arg_on);
1650  return return_list;
1651}
1652
1653void *concatenate(void *prog_list)
1654{
1655  void *el_list=CDR(prog_list);
1656  PtrRef ref1(prog_list), ref2(el_list);
1657  void *ret=NULL;
1658  void *rtype = CAR(prog_list)->Eval();
1659
1660  long len=0;                                // determin the length of the resulting string
1661  if (rtype==string_symbol)
1662  {
1663    int elements = ((LList *)el_list)->GetLength(); // see how many things we need to concat
1664    if (!elements) ret = LString::Create("");
1665    else
1666    {
1667      void **str_eval=(void **)malloc(elements*sizeof(void *));
1668      int i, old_ptr_stack_start=PtrRef::stack.son;
1669
1670      // evalaute all the strings and count their lengths
1671      for (i=0; i<elements; i++, el_list=CDR(el_list))
1672      {
1673        str_eval[i] = CAR(el_list)->Eval();
1674    PtrRef::stack.push(&str_eval[i]);
1675
1676    switch ((short)item_type(str_eval[i]))
1677    {
1678      case L_CONS_CELL :
1679      {
1680        LList *char_list=(LList *)str_eval[i];
1681        while (char_list)
1682        {
1683          if (item_type(CAR(char_list))==(ltype)L_CHARACTER)
1684            len++;
1685          else
1686          {
1687        ((LObject *)str_eval[i])->Print();
1688        lbreak(" is not a character\n");
1689        exit(0);
1690          }
1691          char_list=(LList *)CDR(char_list);
1692        }
1693      } break;
1694      case L_STRING : len+=strlen(lstring_value(str_eval[i])); break;
1695      default :
1696        ((LObject *)prog_list)->Print();
1697        lbreak("type not supported\n");
1698        exit(0);
1699      break;
1700
1701    }
1702      }
1703      LString *st = LString::Create(len+1);
1704      char *s=lstring_value(st);
1705
1706      // now add the string up into the new string
1707      for (i=0; i<elements; i++)
1708      {
1709    switch ((short)item_type(str_eval[i]))
1710    {
1711      case L_CONS_CELL :
1712      {
1713        LList *char_list=(LList *)str_eval[i];
1714        while (char_list)
1715        {
1716          if (item_type(CAR(char_list))==L_CHARACTER)
1717            *(s++)=((LChar *)CAR(char_list))->ch;
1718          char_list=(LList *)CDR(char_list);
1719        }
1720      } break;
1721      case L_STRING :
1722      {
1723        memcpy(s, lstring_value(str_eval[i]), strlen(lstring_value(str_eval[i])));
1724        s+=strlen(lstring_value(str_eval[i]));
1725      } break;
1726      default : ;     // already checked for, but make compiler happy
1727    }
1728      }
1729      free(str_eval);
1730      PtrRef::stack.son=old_ptr_stack_start;   // restore pointer GC stack
1731      *s=0;
1732      ret=st;
1733    }
1734  }
1735  else
1736  {
1737    ((LObject *)prog_list)->Print();
1738    lbreak("concat operation not supported, try 'string\n");
1739    exit(0);
1740  }
1741  return ret;
1742}
1743
1744
1745void *backquote_eval(void *args)
1746{
1747  if (item_type(args)!=L_CONS_CELL)
1748    return args;
1749  else if (args==NULL)
1750    return NULL;
1751  else if ((LSymbol *) (((LList *)args)->car)==comma_symbol)
1752    return CAR(CDR(args))->Eval();
1753  else
1754  {
1755    void *first=NULL, *last=NULL, *cur=NULL, *tmp;
1756    PtrRef ref1(first), ref2(last), ref3(cur), ref4(args);
1757    while (args)
1758    {
1759      if (item_type(args)==L_CONS_CELL)
1760      {
1761    if (CAR(args)==comma_symbol)               // dot list with a comma?
1762    {
1763      tmp = CAR(CDR(args))->Eval();
1764      ((LList *)last)->cdr = (LObject *)tmp;
1765      args=NULL;
1766    }
1767    else
1768    {
1769      cur = LList::Create();
1770      if (first)
1771        ((LList *)last)->cdr = (LObject *)cur;
1772      else
1773            first=cur;
1774      last=cur;
1775          tmp=backquote_eval(CAR(args));
1776          ((LList *)cur)->car = (LObject *)tmp;
1777       args=CDR(args);
1778    }
1779      } else
1780      {
1781    tmp=backquote_eval(args);
1782    ((LList *)last)->cdr = (LObject *)tmp;
1783    args=NULL;
1784      }
1785
1786    }
1787    return (void *)first;
1788  }
1789  return NULL;       // for stupid compiler messages
1790}
1791
1792
1793void *eval_sys_function(LSysFunction *fun, void *arg_list)
1794{
1795  PtrRef ref1(arg_list);
1796  void *ret=NULL;
1797  switch (fun->fun_number)
1798  {
1799    case SYS_FUNC_PRINT:
1800    {
1801      ret=NULL;
1802      while (arg_list)
1803      {
1804        ret = CAR(arg_list)->Eval();
1805        arg_list=CDR(arg_list);
1806        ((LObject *)ret)->Print();
1807      }
1808      return ret;
1809    } break;
1810    case SYS_FUNC_CAR:
1811    { ret=lcar(CAR(arg_list)->Eval()); } break;
1812    case SYS_FUNC_CDR:
1813    { ret=lcdr(CAR(arg_list)->Eval()); } break;
1814    case SYS_FUNC_LENGTH:
1815    {
1816      void *v = CAR(arg_list)->Eval();
1817      switch (item_type(v))
1818      {
1819        case L_STRING : ret = LNumber::Create(strlen(lstring_value(v))); break;
1820        case L_CONS_CELL : ret = LNumber::Create(((LList *)v)->GetLength()); break;
1821        default :
1822        {
1823          ((LObject *)v)->Print();
1824          lbreak("length : type not supported\n");
1825        }
1826      }
1827    } break;
1828    case SYS_FUNC_LIST:
1829    {
1830      void *cur=NULL, *last=NULL, *first=NULL;
1831      PtrRef r1(cur), r2(first), r3(last);
1832      while (arg_list)
1833      {
1834    cur = LList::Create();
1835    void *val = CAR(arg_list)->Eval();
1836    ((LList *) cur)->car = (LObject *)val;
1837    if (last)
1838      ((LList *)last)->cdr = (LObject *)cur;
1839    else first=cur;
1840    last=cur;
1841    arg_list=(LList *)CDR(arg_list);
1842      }
1843      ret=first;
1844    } break;
1845    case SYS_FUNC_CONS:
1846    { void *c = LList::Create();
1847      PtrRef r1(c);
1848      void *val = CAR(arg_list)->Eval();
1849      ((LList *)c)->car = (LObject *)val;
1850      val = CAR(CDR(arg_list))->Eval();
1851      ((LList *)c)->cdr = (LObject *)val;
1852      ret=c;
1853    } break;
1854    case SYS_FUNC_QUOTE:
1855    ret=CAR(arg_list);
1856    break;
1857    case SYS_FUNC_EQ:
1858    {
1859      l_user_stack.push(CAR(arg_list)->Eval());
1860      l_user_stack.push(CAR(CDR(arg_list))->Eval());
1861      ret=lisp_eq(l_user_stack.pop(1), l_user_stack.pop(1));
1862    } break;
1863    case SYS_FUNC_EQUAL:
1864    {
1865      l_user_stack.push(CAR(arg_list)->Eval());
1866      l_user_stack.push(CAR(CDR(arg_list))->Eval());
1867      ret=lisp_equal(l_user_stack.pop(1), l_user_stack.pop(1));
1868    } break;
1869    case SYS_FUNC_PLUS:
1870    {
1871      long sum=0;
1872      while (arg_list)
1873      {
1874    sum+=lnumber_value(CAR(arg_list)->Eval());
1875    arg_list=CDR(arg_list);
1876      }
1877      ret = LNumber::Create(sum);
1878    }
1879    break;
1880    case SYS_FUNC_TIMES:
1881    {
1882      long sum;
1883      void *first = CAR(arg_list)->Eval();
1884      PtrRef r1(first);
1885      if (arg_list && item_type(first)==L_FIXED_POINT)
1886      {
1887    sum=1<<16;
1888    do
1889    {
1890      sum=(sum>>8)*(lfixed_point_value(first)>>8);
1891      arg_list=CDR(arg_list);
1892      if (arg_list) first = CAR(arg_list)->Eval();
1893    } while (arg_list);
1894
1895    ret = LFixedPoint::Create(sum);
1896      } else
1897      { sum=1;
1898    do
1899    {
1900      sum*=lnumber_value(CAR(arg_list)->Eval());
1901      arg_list=CDR(arg_list);
1902      if (arg_list) first =CAR(arg_list)->Eval();
1903    } while (arg_list);
1904    ret = LNumber::Create(sum);
1905      }
1906    }
1907    break;
1908    case SYS_FUNC_SLASH:
1909    {
1910      long sum=0, first=1;
1911      while (arg_list)
1912      {
1913    void *i = CAR(arg_list)->Eval();
1914    PtrRef r1(i);
1915    if (item_type(i)!=L_NUMBER)
1916    {
1917      ((LObject *)i)->Print();
1918      lbreak("/ only defined for numbers, cannot divide ");
1919      exit(0);
1920    } else if (first)
1921    {
1922      sum=((LNumber *)i)->num;
1923      first=0;
1924    }
1925    else sum/=((LNumber *)i)->num;
1926    arg_list=CDR(arg_list);
1927      }
1928      ret = LNumber::Create(sum);
1929    }
1930    break;
1931    case SYS_FUNC_MINUS:
1932    {
1933      long x=lnumber_value(CAR(arg_list)->Eval());
1934      arg_list=CDR(arg_list);
1935      while (arg_list)
1936      {
1937    x-=lnumber_value(CAR(arg_list)->Eval());
1938    arg_list=CDR(arg_list);
1939      }
1940      ret = LNumber::Create(x);
1941    }
1942    break;
1943    case SYS_FUNC_IF:
1944    {
1945      if (CAR(arg_list)->Eval())
1946      ret=CAR(CDR(arg_list))->Eval();
1947      else
1948      { arg_list=CDR(CDR(arg_list));                 // check for a else part
1949    if (arg_list)
1950      ret = CAR(arg_list)->Eval();
1951    else ret=NULL;
1952      }
1953    } break;
1954    case SYS_FUNC_SETQ:
1955    case SYS_FUNC_SETF:
1956    {
1957      void *set_to = CAR(CDR(arg_list))->Eval(), *i=NULL;
1958      PtrRef r1(set_to), r2(i);
1959      i=CAR(arg_list);
1960
1961      ltype x=item_type(set_to);
1962      switch (item_type(i))
1963      {
1964        case L_SYMBOL :
1965        {
1966          switch (item_type (((LSymbol *)i)->value))
1967          {
1968            case L_NUMBER :
1969            {
1970              if (x==L_NUMBER && ((LSymbol *)i)->value!=l_undefined)
1971                ((LSymbol *)i)->SetNumber(lnumber_value(set_to));
1972              else
1973                ((LSymbol *)i)->SetValue((LNumber *)set_to);
1974            } break;
1975            case L_OBJECT_VAR :
1976            {
1977              l_obj_set(((LObjectVar *)(((LSymbol *)i)->value))->index, set_to);
1978            } break;
1979            default :
1980              ((LSymbol *)i)->SetValue((LObject *)set_to);
1981          }
1982          ret=((LSymbol *)i)->value;
1983        } break;
1984        case L_CONS_CELL :   // this better be an 'aref'
1985        {
1986#ifdef TYPE_CHECKING
1987          void *car=((LList *)i)->car;
1988          if (car==car_symbol)
1989          {
1990            car = CAR(CDR(i))->Eval();
1991            if (!car || item_type(car)!=L_CONS_CELL)
1992            { ((LObject *)car)->Print(); lbreak("setq car : evaled object is not a cons cell\n"); exit(0); }
1993            ((LList *)car)->car = (LObject *)set_to;
1994          } else if (car==cdr_symbol)
1995          {
1996            car = CAR(CDR(i))->Eval();
1997            if (!car || item_type(car)!=L_CONS_CELL)
1998            { ((LObject *)car)->Print(); lbreak("setq cdr : evaled object is not a cons cell\n"); exit(0); }
1999            ((LList *)car)->cdr = (LObject *)set_to;
2000          } else if (car==aref_symbol)
2001          {
2002#endif
2003            LArray *a = (LArray *)CAR(CDR(i))->Eval();
2004            PtrRef r1(a);
2005#ifdef TYPE_CHECKING
2006            if (item_type(a) != L_1D_ARRAY)
2007            {
2008                a->Print();
2009                lbreak("is not an array (aref)\n");
2010                exit(0);
2011            }
2012#endif
2013            int num = lnumber_value(CAR(CDR(CDR(i)))->Eval());
2014#ifdef TYPE_CHECKING
2015            if (num >= (int)a->len || num < 0)
2016            {
2017              lbreak("aref : value of bounds (%d)\n", num);
2018              exit(0);
2019            }
2020#endif
2021            a->GetData()[num] = (LObject *)set_to;
2022#ifdef TYPE_CHECKING
2023          } else
2024          {
2025            lbreak("expected (aref, car, cdr, or symbol) in setq\n");
2026            exit(0);
2027          }
2028#endif
2029          ret=set_to;
2030        } break;
2031
2032        default :
2033        {
2034          ((LObject *)i)->Print();
2035          lbreak("setq/setf only defined for symbols and arrays now..\n");
2036          exit(0);
2037        }
2038      }
2039    } break;
2040    case SYS_FUNC_SYMBOL_LIST:
2041      ret=NULL;
2042    break;
2043    case SYS_FUNC_ASSOC:
2044    {
2045      void *item = CAR(arg_list)->Eval();
2046      PtrRef r1(item);
2047      void *list=(LList *)CAR(CDR(arg_list))->Eval();
2048      PtrRef r2(list);
2049      ret=assoc(item, (LList *)list);
2050    } break;
2051    case SYS_FUNC_NOT:
2052    case SYS_FUNC_NULL:
2053    if (CAR(arg_list)->Eval()==NULL) ret=true_symbol; else ret=NULL;
2054    break;
2055    case SYS_FUNC_ACONS:
2056    {
2057      void *i1 = CAR(arg_list)->Eval(), *i2 = CAR(CDR(arg_list))->Eval();
2058      PtrRef r1(i1);
2059      LList *cs = LList::Create();
2060      cs->car = (LObject *)i1;
2061      cs->cdr = (LObject *)i2;
2062      ret=cs;
2063    } break;
2064
2065    case SYS_FUNC_PAIRLIS:
2066    {
2067      l_user_stack.push(CAR(arg_list)->Eval());
2068      arg_list=CDR(arg_list);
2069      l_user_stack.push(CAR(arg_list)->Eval());
2070      arg_list=CDR(arg_list);
2071      void *n3 = CAR(arg_list)->Eval();
2072      void *n2=l_user_stack.pop(1);
2073      void *n1=l_user_stack.pop(1);
2074      ret=pairlis(n1, n2, n3);
2075    } break;
2076    case SYS_FUNC_LET:
2077    {
2078      // make an a-list of new variable names and new values
2079      void *var_list=CAR(arg_list),
2080           *block_list=CDR(arg_list);
2081      PtrRef r1(block_list), r2(var_list);
2082      long stack_start=l_user_stack.son;
2083
2084      while (var_list)
2085      {
2086    void *var_name=CAR(CAR(var_list)), *tmp;
2087#ifdef TYPE_CHECKING
2088    if (item_type(var_name)!=L_SYMBOL)
2089    {
2090      ((LObject *)var_name)->Print();
2091      lbreak("should be a symbol (let)\n");
2092      exit(0);
2093    }
2094#endif
2095
2096    l_user_stack.push(((LSymbol *)var_name)->value);
2097    tmp = CAR(CDR(CAR(var_list)))->Eval();
2098    ((LSymbol *)var_name)->SetValue((LObject *)tmp);
2099    var_list=CDR(var_list);
2100      }
2101
2102      // now evaluate each of the blocks with the new enviroment and return value
2103      // from the last block
2104      while (block_list)
2105      {
2106    ret = CAR(block_list)->Eval();
2107    block_list=CDR(block_list);
2108      }
2109
2110      long cur_stack=stack_start;
2111      var_list=CAR(arg_list);      // now restore the old symbol values
2112      while (var_list)
2113      {
2114    void *var_name=CAR(CAR(var_list));
2115    ((LSymbol *)var_name)->SetValue((LObject *)l_user_stack.sdata[cur_stack++]);
2116    var_list=CDR(var_list);
2117      }
2118      l_user_stack.son=stack_start;     // restore the stack
2119    }
2120    break;
2121    case SYS_FUNC_DEFUN:
2122    {
2123      LSymbol *symbol = (LSymbol *)CAR(arg_list);
2124#ifdef TYPE_CHECKING
2125      if (item_type(symbol)!=L_SYMBOL)
2126      {
2127        symbol->Print();
2128    lbreak(" is not a symbol! (DEFUN)\n");
2129    exit(0);
2130      }
2131
2132      if (item_type(arg_list)!=L_CONS_CELL)
2133      {
2134    ((LObject *)arg_list)->Print();
2135    lbreak("is not a lambda list (DEFUN)\n");
2136    exit(0);
2137      }
2138#endif
2139      void *block_list=CDR(CDR(arg_list));
2140
2141#ifndef NO_LIBS
2142      intptr_t a=cache.reg_lisp_block(lcar(lcdr(arg_list)));
2143      intptr_t b=cache.reg_lisp_block(block_list);
2144      LUserFunction *ufun=new_lisp_user_function(a, b);
2145#else
2146      LUserFunction *ufun=new_lisp_user_function(lcar(lcdr(arg_list)), block_list);
2147#endif
2148      symbol->SetFunction(ufun);
2149      ret=symbol;
2150    } break;
2151    case SYS_FUNC_ATOM:
2152    { ret=lisp_atom(CAR(arg_list)->Eval()); }
2153    case SYS_FUNC_AND:
2154    {
2155      void *l=arg_list;
2156      PtrRef r1(l);
2157      ret=true_symbol;
2158      while (l)
2159      {
2160    if (!CAR(l)->Eval())
2161    {
2162      ret=NULL;
2163      l=NULL;             // short-circuit
2164    } else l=CDR(l);
2165      }
2166    } break;
2167    case SYS_FUNC_OR:
2168    {
2169      void *l=arg_list;
2170      PtrRef r1(l);
2171      ret=NULL;
2172      while (l)
2173      {
2174    if (CAR(l)->Eval())
2175    {
2176      ret=true_symbol;
2177      l=NULL;            // short circuit
2178    } else l=CDR(l);
2179      }
2180    } break;
2181    case SYS_FUNC_PROGN:
2182    { ret=eval_block(arg_list); } break;
2183    case SYS_FUNC_CONCATENATE:
2184      ret=concatenate(arg_list);
2185    break;
2186    case SYS_FUNC_CHAR_CODE:
2187    {
2188      void *i = CAR(arg_list)->Eval();
2189      PtrRef r1(i);
2190      ret=NULL;
2191      switch (item_type(i))
2192      {
2193        case L_CHARACTER :
2194        { ret = LNumber::Create(((LChar *)i)->ch); } break;
2195        case L_STRING :
2196        {  ret = LNumber::Create(*lstring_value(i)); } break;
2197        default :
2198        {
2199          ((LObject *)i)->Print();
2200          lbreak(" is not character type\n");
2201          exit(0);
2202        }
2203      }
2204    } break;
2205    case SYS_FUNC_CODE_CHAR:
2206    {
2207      void *i = CAR(arg_list)->Eval();
2208      PtrRef r1(i);
2209      if (item_type(i)!=L_NUMBER)
2210      {
2211    ((LObject *)i)->Print();
2212    lbreak(" is not number type\n");
2213    exit(0);
2214      }
2215      ret = LChar::Create(((LNumber *)i)->num);
2216    } break;
2217    case SYS_FUNC_COND:
2218    {
2219      void *block_list=CAR(arg_list);
2220      PtrRef r1(block_list);
2221      if (!block_list) ret=NULL;
2222      else
2223      {
2224    ret=NULL;
2225        while (block_list)
2226    {
2227      if (lcar(CAR(block_list))->Eval())
2228        ret = CAR(CDR(CAR(block_list)))->Eval();
2229      block_list=CDR(block_list);
2230    }
2231      }
2232    } break;
2233    case SYS_FUNC_SELECT:
2234    {
2235      void *selector = CAR(arg_list)->Eval();
2236      void *sel=CDR(arg_list);
2237      PtrRef r1(selector), r2(sel);
2238      while (sel)
2239      {
2240    if (lisp_equal(selector, CAR(CAR(sel))->Eval()))
2241    {
2242      sel=CDR(CAR(sel));
2243      while (sel)
2244      {
2245        ret = CAR(sel)->Eval();
2246        sel=CDR(sel);
2247      }
2248      sel=NULL;
2249    } else sel=CDR(sel);
2250      }
2251    } break;
2252    case SYS_FUNC_FUNCTION:
2253      ret = ((LSymbol *)CAR(arg_list)->Eval())->GetFunction();
2254    break;
2255    case SYS_FUNC_MAPCAR:
2256      ret=mapcar(arg_list);
2257    case SYS_FUNC_FUNCALL:
2258    {
2259      void *n1 = CAR(arg_list)->Eval();
2260      ret = ((LSymbol *)n1)->EvalFunction(CDR(arg_list));
2261    } break;
2262    case SYS_FUNC_GT:
2263    {
2264      long n1=lnumber_value(CAR(arg_list)->Eval());
2265      long n2=lnumber_value(CAR(CDR(arg_list))->Eval());
2266      if (n1>n2) ret=true_symbol; else ret=NULL;
2267    }
2268    break;
2269    case SYS_FUNC_LT:
2270    {
2271      long n1=lnumber_value(CAR(arg_list)->Eval());
2272      long n2=lnumber_value(CAR(CDR(arg_list))->Eval());
2273      if (n1<n2) ret=true_symbol; else ret=NULL;
2274    }
2275    break;
2276    case SYS_FUNC_GE:
2277    {
2278      long n1=lnumber_value(CAR(arg_list)->Eval());
2279      long n2=lnumber_value(CAR(CDR(arg_list))->Eval());
2280      if (n1>=n2) ret=true_symbol; else ret=NULL;
2281    }
2282    break;
2283    case SYS_FUNC_LE:
2284    {
2285      long n1=lnumber_value(CAR(arg_list)->Eval());
2286      long n2=lnumber_value(CAR(CDR(arg_list))->Eval());
2287      if (n1<=n2) ret=true_symbol; else ret=NULL;
2288    }
2289    break;
2290
2291    case SYS_FUNC_TMP_SPACE:
2292      tmp_space();
2293      ret=true_symbol;
2294    break;
2295    case SYS_FUNC_PERM_SPACE:
2296      perm_space();
2297      ret=true_symbol;
2298    break;
2299    case SYS_FUNC_SYMBOL_NAME:
2300      LSymbol *symb;
2301      symb = (LSymbol *)CAR(arg_list)->Eval();
2302#ifdef TYPE_CHECKING
2303      if (item_type(symb)!=L_SYMBOL)
2304      {
2305        symb->Print();
2306        lbreak(" is not a symbol (symbol-name)\n");
2307        exit(0);
2308      }
2309#endif
2310      ret = symb->name;
2311    break;
2312    case SYS_FUNC_TRACE:
2313      trace_level++;
2314      if (arg_list)
2315        trace_print_level=lnumber_value(CAR(arg_list)->Eval());
2316      ret=true_symbol;
2317    break;
2318    case SYS_FUNC_UNTRACE:
2319      if (trace_level>0)
2320      {
2321                trace_level--;
2322                ret=true_symbol;
2323      } else ret=NULL;
2324    break;
2325    case SYS_FUNC_DIGSTR:
2326    {
2327      char tmp[50], *tp;
2328      long num=lnumber_value(CAR(arg_list)->Eval());
2329      long dig=lnumber_value(CAR(CDR(arg_list))->Eval());
2330      tp=tmp+49;
2331      *(tp--)=0;
2332      for (; num; )
2333      {
2334                int d;
2335                d=num%10;
2336                *(tp--)=d+'0';
2337                num/=10;
2338                dig--;
2339      }
2340      while (dig--)
2341        *(tp--)='0';
2342      ret=LString::Create(tp+1);
2343    } break;
2344    case SYS_FUNC_LOCAL_LOAD:
2345    case SYS_FUNC_LOAD:
2346    case SYS_FUNC_COMPILE_FILE:
2347    {
2348            void *fn = CAR(arg_list)->Eval();
2349            char *st = lstring_value( fn );
2350            PtrRef r1( fn );
2351            bFILE *fp;
2352            if( fun->fun_number == SYS_FUNC_LOCAL_LOAD )
2353            {
2354                // A special test for gamma.lsp
2355                if( strcmp( st, "gamma.lsp" ) == 0 )
2356                {
2357                    char *gammapath;
2358                    gammapath = (char *)malloc( strlen( get_save_filename_prefix() ) + 9 + 1 );
2359                    sprintf( gammapath, "%sgamma.lsp", get_save_filename_prefix() );
2360                    fp = new jFILE( gammapath, "rb" );
2361                    free( gammapath );
2362                }
2363                else
2364                {
2365                    fp = new jFILE( st, "rb" );
2366                }
2367            }
2368            else
2369            {
2370                fp = open_file(st, "rb");
2371            }
2372
2373            if( fp->open_failure() )
2374            {
2375                delete fp;
2376                if( DEFINEDP(((LSymbol *)load_warning)->GetValue())
2377                     && ((LSymbol *)load_warning)->GetValue())
2378                    dprintf("Warning : file %s does not exist\n", st);
2379                ret = NULL;
2380            }
2381            else
2382            {
2383                long l=fp->file_size();
2384                char *s=(char *)malloc(l + 1);
2385                if (!s)
2386                {
2387                  printf("Malloc error in load_script\n");
2388                  exit(0);
2389                }
2390
2391                fp->read(s, l);
2392                s[l]=0;
2393                delete fp;
2394                char const *cs=s;
2395            #ifndef NO_LIBS
2396                char msg[100];
2397                sprintf(msg, "(load \"%s\")", st);
2398                if (stat_man) stat_man->push(msg, NULL);
2399                crc_manager.get_filenumber(st);               // make sure this file gets crc'ed
2400            #endif
2401                LObject *compiled_form = NULL;
2402                PtrRef r11(compiled_form);
2403                while (!end_of_program(cs))  // see if there is anything left to compile and run
2404                {
2405            #ifndef NO_LIBS
2406                  if (stat_man) stat_man->update((cs-s)*100/l);
2407            #endif
2408                  void *m=mark_heap(TMP_SPACE);
2409                  compiled_form=LObject::Compile(cs);
2410                  compiled_form->Eval();
2411                  compiled_form=NULL;
2412                  restore_heap(m, TMP_SPACE);
2413                }
2414            #ifndef NO_LIBS
2415                                if (stat_man) stat_man->update(100);
2416                if (stat_man) stat_man->pop();
2417            #endif
2418                free(s);
2419                ret=fn;
2420      }
2421    } break;
2422    case SYS_FUNC_ABS:
2423      ret = LNumber::Create(abs(lnumber_value(CAR(arg_list)->Eval()))); break;
2424    case SYS_FUNC_MIN:
2425    {
2426      int x=lnumber_value(CAR(arg_list)->Eval()),
2427          y=lnumber_value(CAR(CDR(arg_list))->Eval());
2428      ret = LNumber::Create(x < y ? x : y);
2429    } break;
2430    case SYS_FUNC_MAX:
2431    {
2432      int x=lnumber_value(CAR(arg_list)->Eval()),
2433          y=lnumber_value(CAR(CDR(arg_list))->Eval());
2434      ret = LNumber::Create(x > y ? x : y);
2435    } break;
2436    case SYS_FUNC_BACKQUOTE:
2437    {
2438      ret=backquote_eval(CAR(arg_list));
2439    } break;
2440    case SYS_FUNC_COMMA:
2441    {
2442      ((LObject *)arg_list)->Print();
2443      lbreak("comma is illegal outside of backquote\n");
2444      exit(0);
2445      ret=NULL;
2446    } break;
2447    case SYS_FUNC_NTH:
2448    {
2449      long x=lnumber_value(CAR(arg_list)->Eval());
2450      ret=nth(x, CAR(CDR(arg_list))->Eval());
2451    } break;
2452    case SYS_FUNC_RESIZE_TMP:
2453        resize_tmp(lnumber_value(CAR(arg_list)->Eval())); break;
2454    case SYS_FUNC_RESIZE_PERM:
2455        resize_perm(lnumber_value(CAR(arg_list)->Eval())); break;
2456    case SYS_FUNC_COS:
2457        ret = LFixedPoint::Create(lisp_cos(lnumber_value(CAR(arg_list)->Eval()))); break;
2458    case SYS_FUNC_SIN:
2459        ret = LFixedPoint::Create(lisp_sin(lnumber_value(CAR(arg_list)->Eval()))); break;
2460    case SYS_FUNC_ATAN2:
2461    {
2462      long y=(lnumber_value(CAR(arg_list)->Eval()));   arg_list=CDR(arg_list);
2463      long x=(lnumber_value(CAR(arg_list)->Eval()));
2464      ret = LNumber::Create(lisp_atan2(y, x));
2465    } break;
2466    case SYS_FUNC_ENUM:
2467    {
2468      int sp=current_space;
2469      current_space=PERM_SPACE;
2470      long x=0;
2471      while (arg_list)
2472      {
2473    void *sym = CAR(arg_list)->Eval();
2474    PtrRef r1(sym);
2475    switch (item_type(sym))
2476    {
2477      case L_SYMBOL :
2478      { ((LSymbol *)sym)->value = LNumber::Create(x); } break;
2479      case L_CONS_CELL :
2480      {
2481        void *s = CAR(sym)->Eval();
2482        PtrRef r1(s);
2483#ifdef TYPE_CHECKING
2484        if (item_type(s)!=L_SYMBOL)
2485        {
2486          ((LObject *)arg_list)->Print();
2487          lbreak("expecting (sybmol value) for enum\n");
2488          exit(0);
2489        }
2490#endif
2491        x=lnumber_value(CAR(CDR(sym))->Eval());
2492        ((LSymbol *)sym)->value = LNumber::Create(x);
2493      } break;
2494      default :
2495      {
2496        ((LObject *)arg_list)->Print();
2497        lbreak("expecting symbol or (symbol value) in enum\n");
2498        exit(0);
2499      }
2500    }
2501    arg_list=CDR(arg_list);
2502    x++;
2503      }
2504      current_space=sp;
2505    } break;
2506    case SYS_FUNC_QUIT:
2507    {
2508      exit(0);
2509    } break;
2510    case SYS_FUNC_EVAL:
2511    {
2512      ret = CAR(arg_list)->Eval()->Eval();
2513    } break;
2514    case SYS_FUNC_BREAK: lbreak("User break"); break;
2515    case SYS_FUNC_MOD:
2516    {
2517      long x=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
2518      long y=lnumber_value(CAR(arg_list)->Eval());
2519      if (y==0) { lbreak("mod : division by zero\n"); y=1; }
2520      ret = LNumber::Create(x%y);
2521    } break;
2522/*    case SYS_FUNC_WRITE_PROFILE:
2523    {
2524      char *fn=lstring_value(CAR(arg_list)->Eval());
2525      FILE *fp=fopen(fn, "wb");
2526      if (!fp)
2527        lbreak("could not open %s for writing", fn);
2528      else
2529      {
2530    for (void *s=symbol_list; s; s=CDR(s))
2531      fprintf(fp, "%8d  %s\n", ((LSymbol *)(CAR(s)))->call_counter,
2532          lstring_value(((LSymbol *)(CAR(s)))->name));
2533    fclose(fp);
2534      }
2535    } break; */
2536    case SYS_FUNC_FOR:
2537    {
2538      LSymbol *bind_var = (LSymbol *)CAR(arg_list);
2539      arg_list = CDR(arg_list);
2540      PtrRef r1(bind_var);
2541      if (item_type(bind_var)!=L_SYMBOL)
2542      { lbreak("expecting for iterator to be a symbol\n"); exit(1); }
2543
2544      if (CAR(arg_list)!=in_symbol)
2545      { lbreak("expecting in after 'for iterator'\n"); exit(1); }
2546      arg_list=CDR(arg_list);
2547
2548      void *ilist = CAR(arg_list)->Eval(); arg_list=CDR(arg_list);
2549      PtrRef r2(ilist);
2550
2551      if (CAR(arg_list)!=do_symbol)
2552      { lbreak("expecting do after 'for iterator in list'\n"); exit(1); }
2553      arg_list=CDR(arg_list);
2554
2555      void *block=NULL, *ret=NULL;
2556      PtrRef r3(block);
2557      l_user_stack.push(bind_var->GetValue());  // save old symbol value
2558      while (ilist)
2559      {
2560                bind_var->SetValue((LObject *)CAR(ilist));
2561                for (block=arg_list; block; block=CDR(block))
2562                  ret = CAR(block)->Eval();
2563                ilist=CDR(ilist);
2564      }
2565      bind_var->SetValue((LObject *)l_user_stack.pop(1)); // restore symbol value
2566      ret=ret;
2567    } break;
2568    case SYS_FUNC_OPEN_FILE:
2569    {
2570      bFILE *old_file=current_print_file;
2571      void *str1 = CAR(arg_list)->Eval();
2572      PtrRef r1(str1);
2573      void *str2 = CAR(CDR(arg_list))->Eval();
2574
2575
2576      current_print_file=open_file(lstring_value(str1),
2577                   lstring_value(str2));
2578
2579      if (!current_print_file->open_failure())
2580      {
2581                while (arg_list)
2582                {
2583                  ret = CAR(arg_list)->Eval();
2584                  arg_list=CDR(arg_list);
2585                }
2586      }
2587      delete current_print_file;
2588      current_print_file=old_file;
2589
2590    } break;
2591    case SYS_FUNC_BIT_AND:
2592    {
2593      long first=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
2594      while (arg_list)
2595      {
2596        first&=lnumber_value(CAR(arg_list)->Eval());
2597                arg_list=CDR(arg_list);
2598      }
2599      ret = LNumber::Create(first);
2600    } break;
2601    case SYS_FUNC_BIT_OR:
2602    {
2603      long first=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
2604      while (arg_list)
2605      {
2606        first|=lnumber_value(CAR(arg_list)->Eval());
2607                arg_list=CDR(arg_list);
2608      }
2609      ret = LNumber::Create(first);
2610    } break;
2611    case SYS_FUNC_BIT_XOR:
2612    {
2613      long first=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
2614      while (arg_list)
2615      {
2616        first^=lnumber_value(CAR(arg_list)->Eval());
2617                arg_list=CDR(arg_list);
2618      }
2619      ret = LNumber::Create(first);
2620    } break;
2621    case SYS_FUNC_MAKE_ARRAY:
2622    {
2623      long l=lnumber_value(CAR(arg_list)->Eval());
2624      if (l>=2<<16 || l<=0)
2625      {
2626                lbreak("bad array size %d\n", l);
2627                exit(0);
2628      }
2629      ret = LArray::Create(l, CDR(arg_list));
2630    } break;
2631    case SYS_FUNC_AREF:
2632    {
2633      long x=lnumber_value(CAR(CDR(arg_list))->Eval());
2634      ret = ((LArray *)CAR(arg_list)->Eval())->Get(x);
2635    } break;
2636    case SYS_FUNC_IF_1PROGN:
2637    {
2638      if (CAR(arg_list)->Eval())
2639        ret=eval_block(CAR(CDR(arg_list)));
2640      else ret = CAR(CDR(CDR(arg_list)))->Eval();
2641
2642    } break;
2643    case SYS_FUNC_IF_2PROGN:
2644    {
2645      if (CAR(arg_list)->Eval())
2646        ret = CAR(CDR(arg_list))->Eval();
2647      else ret=eval_block(CAR(CDR(CDR(arg_list))));
2648
2649    } break;
2650    case SYS_FUNC_IF_12PROGN:
2651    {
2652      if (CAR(arg_list)->Eval())
2653        ret=eval_block(CAR(CDR(arg_list)));
2654      else ret=eval_block(CAR(CDR(CDR(arg_list))));
2655
2656    } break;
2657    case SYS_FUNC_EQ0:
2658    {
2659      void *v = CAR(arg_list)->Eval();
2660      if (item_type(v)!=L_NUMBER || (((LNumber *)v)->num!=0))
2661        ret=NULL;
2662      else ret=true_symbol;
2663    } break;
2664    case SYS_FUNC_PREPORT:
2665    {
2666#ifdef L_PROFILE
2667      char *s=lstring_value(CAR(arg_list)->Eval());
2668      preport(s);
2669#endif
2670    } break;
2671    case SYS_FUNC_SEARCH:
2672    {
2673      void *arg1 = CAR(arg_list)->Eval(); arg_list=CDR(arg_list);
2674      PtrRef r1(arg1);       // protect this refrence
2675      char *haystack=lstring_value(CAR(arg_list)->Eval());
2676      char *needle=lstring_value(arg1);
2677
2678      char *find=strstr(haystack, needle);
2679      if (find)
2680        ret = LNumber::Create(find-haystack);
2681      else ret=NULL;
2682    } break;
2683    case SYS_FUNC_ELT:
2684    {
2685      void *arg1 = CAR(arg_list)->Eval(); arg_list=CDR(arg_list);
2686      PtrRef r1(arg1);       // protect this refrence
2687      long x=lnumber_value(CAR(arg_list)->Eval());
2688      char *st=lstring_value(arg1);
2689      if (x < 0 || (unsigned)x >= strlen(st))
2690      { lbreak("elt : out of range of string\n"); ret=NULL; }
2691      else
2692        ret = LChar::Create(st[x]);
2693    } break;
2694    case SYS_FUNC_LISTP:
2695    {
2696      return item_type(CAR(arg_list)->Eval())==L_CONS_CELL ? true_symbol : NULL;
2697    } break;
2698    case SYS_FUNC_NUMBERP:
2699    {
2700      int t=item_type(CAR(arg_list)->Eval());
2701      if (t==L_NUMBER || t==L_FIXED_POINT) return true_symbol; else return NULL;
2702    } break;
2703    case SYS_FUNC_DO:
2704    {
2705      void *init_var=CAR(arg_list);
2706      PtrRef r1(init_var);
2707      int i, ustack_start=l_user_stack.son;      // restore stack at end
2708      LSymbol *sym = NULL;
2709      PtrRef r2(sym);
2710
2711      // check to make sure iter vars are symbol and push old values
2712      for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var))
2713      {
2714                sym = (LSymbol *)CAR(CAR(init_var));
2715                if (item_type(sym)!=L_SYMBOL)
2716                { lbreak("expecting symbol name for iteration var\n"); exit(0); }
2717                l_user_stack.push(sym->GetValue());
2718      }
2719
2720      void **do_evaled=l_user_stack.sdata+l_user_stack.son;
2721      // push all of the init forms, so we can set the symbol
2722      for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var))
2723                l_user_stack.push(CAR(CDR(CAR((init_var))))->Eval());
2724
2725      // now set all the symbols
2726      for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var), do_evaled++)
2727      {
2728                sym = (LSymbol *)CAR(CAR(init_var));
2729                sym->SetValue((LObject *)*do_evaled);
2730      }
2731
2732      i=0;       // set i to 1 when terminate conditions are meet
2733      do
2734      {
2735                i = CAR(CAR(CDR(arg_list)))->Eval() != NULL;
2736                if (!i)
2737                {
2738                  eval_block(CDR(CDR(arg_list)));
2739                  for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var))
2740                    CAR(CDR(CDR(CAR(init_var))))->Eval();
2741                }
2742      } while (!i);
2743
2744      ret = CAR(CDR(CAR(CDR(arg_list))))->Eval();
2745
2746      // restore old values for symbols
2747      do_evaled=l_user_stack.sdata+ustack_start;
2748      for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var), do_evaled++)
2749      {
2750                sym = (LSymbol *)CAR(CAR(init_var));
2751                sym->SetValue((LObject *)*do_evaled);
2752      }
2753
2754      l_user_stack.son=ustack_start;
2755
2756    } break;
2757    case SYS_FUNC_GC:
2758    {
2759      collect_space(current_space);
2760    } break;
2761    case SYS_FUNC_SCHAR:
2762    {
2763      char *s=lstring_value(CAR(arg_list)->Eval());
2764      arg_list=CDR(arg_list);
2765      long x=lnumber_value(CAR(arg_list)->Eval());
2766
2767      if ((unsigned)x >= strlen(s))
2768      { lbreak("SCHAR: index %d should be less than the length of the string\n", x); exit(0); }
2769      else if (x<0)
2770      { lbreak("SCHAR: index should not be negative\n"); exit(0); }
2771      return LChar::Create(s[x]);
2772    } break;
2773    case SYS_FUNC_SYMBOLP:
2774    { if (item_type(CAR(arg_list)->Eval())==L_SYMBOL) return true_symbol;
2775      else return NULL; } break;
2776    case SYS_FUNC_NUM2STR:
2777    {
2778      char str[20];
2779      sprintf(str, "%ld", (long int)lnumber_value(CAR(arg_list)->Eval()));
2780      ret=LString::Create(str);
2781    } break;
2782    case SYS_FUNC_NCONC:
2783    {
2784      void *l1=CAR(arg_list)->Eval(); arg_list=CDR(arg_list);
2785      PtrRef r1(l1);
2786      void *first=l1, *next;
2787      PtrRef r2(first);
2788
2789      if (!l1)
2790      {
2791                l1=first=CAR(arg_list)->Eval();
2792                arg_list=CDR(arg_list);
2793      }
2794
2795      if (item_type(l1)!=L_CONS_CELL)
2796      { ((LObject *)l1)->Print(); lbreak("first arg should be a list\n"); }
2797      do
2798      {
2799                next=l1;
2800                while (next) { l1=next; next=lcdr(next); }
2801                ((LList *)l1)->cdr = CAR(arg_list)->Eval();
2802                arg_list=CDR(arg_list);
2803      } while (arg_list);
2804      ret=first;
2805    } break;
2806    case SYS_FUNC_FIRST:
2807    { ret=CAR(CAR(arg_list)->Eval()); } break;
2808    case SYS_FUNC_SECOND:
2809    { ret=CAR(CDR(CAR(arg_list)->Eval())); } break;
2810    case SYS_FUNC_THIRD:
2811    { ret=CAR(CDR(CDR(CAR(arg_list)->Eval()))); } break;
2812    case SYS_FUNC_FOURTH:
2813    { ret=CAR(CDR(CDR(CDR(CAR(arg_list)->Eval())))); } break;
2814    case SYS_FUNC_FIFTH:
2815    { ret=CAR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))); } break;
2816    case SYS_FUNC_SIXTH:
2817    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))); } break;
2818    case SYS_FUNC_SEVENTH:
2819    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))); } break;
2820    case SYS_FUNC_EIGHTH:
2821    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))))); } break;
2822    case SYS_FUNC_NINTH:
2823    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))))); } break;
2824    case SYS_FUNC_TENTH:
2825    { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))))))); } break;
2826    case SYS_FUNC_SUBSTR:
2827    {
2828      long x1=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
2829      long x2=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
2830      void *st=CAR(arg_list)->Eval();
2831      PtrRef r1(st);
2832
2833      if (x1 < 0 || x1 > x2 || (unsigned)x2 >= strlen(lstring_value(st)))
2834        lbreak("substr : bad x1 or x2 value");
2835
2836      LString *s=LString::Create(x2-x1+2);
2837      if (x2-x1)
2838        memcpy(lstring_value(s), lstring_value(st)+x1, x2-x1+1);
2839
2840      *(lstring_value(s)+(x2-x1+1))=0;
2841      ret=s;
2842    } break;
2843    case 99 :
2844    {
2845      void *r=NULL, *rstart=NULL;
2846      PtrRef r1(r), r2(rstart);
2847      while (arg_list)
2848      {
2849        void *q = CAR(arg_list)->Eval();
2850        if (!rstart) rstart=q;
2851        while (r && CDR(r)) r=CDR(r);
2852        CDR(r) = (LObject *)q;
2853        arg_list=CDR(arg_list);
2854      }
2855      return rstart;
2856    } break;
2857
2858    default :
2859    { dprintf("Undefined system function number %d\n", ((LSysFunction *)fun)->fun_number); }
2860  }
2861  return ret;
2862}
2863
2864void tmp_space()
2865{
2866  current_space=TMP_SPACE;
2867}
2868
2869void perm_space()
2870{
2871  current_space=PERM_SPACE;
2872}
2873
2874void use_user_space(void *addr, long size)
2875{
2876  current_space = 2;
2877  free_space[USER_SPACE] = space[USER_SPACE] = (uint8_t *)addr;
2878  space_size[USER_SPACE] = size;
2879}
2880
2881
2882void *eval_user_fun(LSymbol *sym, void *arg_list)
2883{
2884  void *ret=NULL;
2885  PtrRef ref1(ret);
2886
2887#ifdef TYPE_CHECKING
2888  if (item_type(sym)!=L_SYMBOL)
2889  {
2890    ((LObject *)sym)->Print();
2891    lbreak("EVAL : is not a function name (not symbol either)");
2892    exit(0);
2893  }
2894#endif
2895#ifdef L_PROFILE
2896  time_marker start;
2897#endif
2898
2899
2900  LUserFunction *fun=(LUserFunction *)(((LSymbol *)sym)->function);
2901
2902#ifdef TYPE_CHECKING
2903  if (item_type(fun)!=L_USER_FUNCTION)
2904  {
2905    ((LObject *)sym)->Print();
2906    lbreak("is not a user defined function\n");
2907  }
2908#endif
2909
2910#ifndef NO_LIBS
2911  void *fun_arg_list=cache.lblock(fun->alist);
2912  void *block_list=cache.lblock(fun->blist);
2913  PtrRef r9(block_list), r10(fun_arg_list);
2914#else
2915  void *fun_arg_list=fun->arg_list;
2916  void *block_list=fun->block_list;
2917  PtrRef r9(block_list), r10(fun_arg_list);
2918#endif
2919
2920
2921
2922  // mark the start start, so we can restore when done
2923  long stack_start=l_user_stack.son;
2924
2925  // first push all of the old symbol values
2926  void *f_arg=fun_arg_list;
2927  PtrRef r18(f_arg);
2928  PtrRef r19(arg_list);
2929  for (; f_arg; f_arg=CDR(f_arg))
2930  {
2931    LSymbol *s = (LSymbol *)CAR(f_arg);
2932    l_user_stack.push(s->value);
2933  }
2934
2935  // open block so that local vars aren't saved on the stack
2936  {
2937    int new_start=l_user_stack.son;
2938    int i=new_start;
2939    // now push all the values we wish to gather
2940    for (f_arg=fun_arg_list; f_arg; )
2941    {
2942      if (!arg_list)
2943      { sym->Print(); lbreak("too few parameter to function\n"); exit(0); }
2944      l_user_stack.push(CAR(arg_list)->Eval());
2945      f_arg=CDR(f_arg);
2946      arg_list=CDR(arg_list);
2947    }
2948
2949
2950    // now store all the values and put them into the symbols
2951    for (f_arg=fun_arg_list; f_arg; f_arg=CDR(f_arg))
2952      ((LSymbol *)CAR(f_arg))->SetValue((LObject *)l_user_stack.sdata[i++]);
2953
2954    l_user_stack.son=new_start;
2955  }
2956
2957
2958
2959  if (f_arg)
2960  { sym->Print(); lbreak("too many parameter to function\n"); exit(0); }
2961
2962
2963  // now evaluate the function block
2964  while (block_list)
2965  {
2966    ret=CAR(block_list)->Eval();
2967    block_list=CDR(block_list);
2968  }
2969
2970  long cur_stack=stack_start;
2971  for (f_arg=fun_arg_list; f_arg; f_arg=CDR(f_arg))
2972    ((LSymbol *)CAR(f_arg))->SetValue((LObject *)l_user_stack.sdata[cur_stack++]);
2973
2974  l_user_stack.son=stack_start;
2975
2976#ifdef L_PROFILE
2977  time_marker end;
2978  sym->time_taken += end.diff_time(&start);
2979#endif
2980
2981
2982  return ret;
2983}
2984
2985LObject *LObject::Eval()
2986{
2987    LObject *ret = NULL;
2988    PtrRef ref1(this);
2989
2990    int tstart = trace_level;
2991
2992    if (trace_level)
2993    {
2994        if (trace_level <= trace_print_level)
2995        {
2996            dprintf("%d (%d, %d, %d) TRACE : ", trace_level,
2997                    get_free_size(PERM_SPACE), get_free_size(TMP_SPACE),
2998                    PtrRef::stack.son);
2999            Print();
3000            dprintf("\n");
3001        }
3002        trace_level++;
3003    }
3004
3005    if (this)
3006    {
3007        switch (item_type(this))
3008        {
3009        case L_BAD_CELL:
3010            lbreak("error: eval on a bad cell\n");
3011            exit(0);
3012            break;
3013        case L_CHARACTER:
3014        case L_STRING:
3015        case L_NUMBER:
3016        case L_POINTER:
3017        case L_FIXED_POINT:
3018            ret = this;
3019            break;
3020        case L_SYMBOL:
3021            if (this == true_symbol)
3022                ret = this;
3023            else
3024            {
3025                ret = ((LSymbol *)this)->GetValue();
3026                if (item_type(ret) == L_OBJECT_VAR)
3027                    ret = (LObject *)l_obj_get(((LObjectVar *)ret)->index);
3028            }
3029            break;
3030        case L_CONS_CELL:
3031            ret = ((LSymbol *)CAR(this))->EvalFunction(CDR(this));
3032            break;
3033        default :
3034            fprintf(stderr, "shouldn't happen\n");
3035            break;
3036        }
3037    }
3038
3039    if (tstart)
3040    {
3041        trace_level--;
3042        if (trace_level <= trace_print_level)
3043            dprintf("%d (%d, %d, %d) TRACE ==> ", trace_level,
3044                    get_free_size(PERM_SPACE), get_free_size(TMP_SPACE),
3045                    PtrRef::stack.son);
3046        ret->Print();
3047        dprintf("\n");
3048    }
3049
3050/*  l_user_stack.push(ret);
3051  collect_space(PERM_SPACE);
3052  ret=l_user_stack.pop(1);  */
3053
3054    return ret;
3055}
3056
3057void resize_perm(int new_size)
3058{
3059  if (new_size<((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]))
3060  {
3061    lbreak("resize perm : %d is to small to hold current heap\n", new_size);
3062    exit(0);
3063  } else if (new_size>space_size[PERM_SPACE])
3064  {
3065    lbreak("Only smaller resizes allowed for now.\n");
3066    exit(0);
3067  } else
3068    dprintf("doesn't work yet!\n");
3069}
3070
3071void resize_tmp(int new_size)
3072{
3073  if (new_size<((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]))
3074  {
3075    lbreak("resize perm : %d is to small to hold current heap\n", new_size);
3076    exit(0);
3077  } else if (new_size>space_size[TMP_SPACE])
3078  {
3079    printf("Only smaller resizes allowed for now.\n");
3080    exit(0);
3081  } else if (free_space[TMP_SPACE]==space[TMP_SPACE])
3082  {
3083    free_space[TMP_SPACE] = space[TMP_SPACE] = (uint8_t *)realloc(space[TMP_SPACE], new_size);
3084    space_size[TMP_SPACE] = new_size;
3085    dprintf("Lisp : tmp space resized to %d\n", new_size);
3086  } else dprintf("Lisp :tmp not empty, cannot resize\n");
3087}
3088
3089void l_comp_init();
3090void lisp_init(long perm_size, long tmp_size)
3091{
3092  unsigned int i;
3093  LSymbol::root = NULL;
3094  total_user_functions = 0;
3095
3096  free_space[0] = space[0] = (uint8_t *)malloc(perm_size);
3097  space_size[0] = perm_size;
3098
3099  free_space[1] = space[1] = (uint8_t *)malloc(tmp_size);
3100  space_size[1] = tmp_size;
3101
3102
3103  current_space=PERM_SPACE;
3104
3105
3106  l_comp_init();
3107  for(i = 0; i < sizeof(sys_funcs) / sizeof(*sys_funcs); i++)
3108    add_sys_function(sys_funcs[i].name,
3109                     sys_funcs[i].min_args, sys_funcs[i].max_args, i);
3110  clisp_init();
3111  current_space=TMP_SPACE;
3112  dprintf("Lisp : %d symbols defined, %d system functions, %d pre-compiled functions\n",
3113      LSymbol::count, sizeof(sys_funcs) / sizeof(*sys_funcs), total_user_functions);
3114}
3115
3116void lisp_uninit()
3117{
3118    free(space[0]);
3119    free(space[1]);
3120    DeleteAllSymbols(LSymbol::root);
3121    LSymbol::root = NULL;
3122    LSymbol::count = 0;
3123}
3124
3125void clear_tmp()
3126{
3127    free_space[TMP_SPACE] = space[TMP_SPACE];
3128}
3129
3130LString *LSymbol::GetName()
3131{
3132#ifdef TYPE_CHECKING
3133    if (item_type(this) != L_SYMBOL)
3134    {
3135        Print();
3136        lbreak("is not a symbol\n");
3137        exit(0);
3138    }
3139#endif
3140    return name;
3141}
3142
3143void LSymbol::SetNumber(long num)
3144{
3145#ifdef TYPE_CHECKING
3146    if (item_type(this) != L_SYMBOL)
3147    {
3148        Print();
3149        lbreak("is not a symbol\n");
3150        exit(0);
3151    }
3152#endif
3153    if (value != l_undefined && item_type(value) == L_NUMBER)
3154        ((LNumber *)value)->num = num;
3155    else
3156        value = LNumber::Create(num);
3157}
3158
3159void LSymbol::SetValue(LObject *val)
3160{
3161#ifdef TYPE_CHECKING
3162    if (item_type(this) != L_SYMBOL)
3163    {
3164        Print();
3165        lbreak("is not a symbol\n");
3166        exit(0);
3167    }
3168#endif
3169    value = val;
3170}
3171
3172LObject *LSymbol::GetFunction()
3173{
3174#ifdef TYPE_CHECKING
3175    if (item_type(this) != L_SYMBOL)
3176    {
3177        Print();
3178        lbreak("is not a symbol\n");
3179        exit(0);
3180    }
3181#endif
3182    return function;
3183}
3184
3185LObject *LSymbol::GetValue()
3186{
3187#ifdef TYPE_CHECKING
3188    if (item_type(this) != L_SYMBOL)
3189    {
3190        Print();
3191        lbreak("is not a symbol\n");
3192        exit(0);
3193    }
3194#endif
3195    return value;
3196}
3197
Note: See TracBrowser for help on using the repository browser.