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

Last change on this file since 481 was 481, checked in by Sam Hocevar, 7 years ago

Fuck the history, I'm renaming all .hpp files to .h for my own sanity.

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