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

Last change on this file since 496 was 496, checked in by Sam Hocevar, 12 years ago

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