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

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

style: remove trailing spaces, fix copyright statements.

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