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

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

core: Get rid of mostly useless headers, move endianness handling to
common.h (and rewrite functions so that they do not need the SDL headers)
and move a few functions out of sdlport's video.cpp. These functions
were in the original video.cpp (which reappears) and shouldn't be part
of the SDL port.

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