source: golgotha/src/i4/lisp/lisp.cc @ 80

Last change on this file since 80 was 80, checked in by Sam Hocevar, 12 years ago
  • Adding the Golgotha source code. Not sure what's going to be interesting in there, but since it's all public domain, there's certainly stuff to pick up.
File size: 16.5 KB
Line 
1/********************************************************************** <BR>
2  This file is part of Crack dot Com's free source code release of
3  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
4  information about compiling & licensing issues visit this URL</a>
5  <PRE> If that doesn't help, contact Jonathan Clark at
6  golgotha_source@usa.net (Subject should have "GOLG" in it)
7***********************************************************************/
8
9#include "error/error.hh"
10#include "main/main.hh"
11#include "init/init.hh"
12#include "file/file.hh"
13#include "lisp/li_types.hh"
14#include "lisp/lisp.hh"
15#include "status/status.hh"
16#include "threads/threads.hh"
17
18#include <stdlib.h>
19#include <string.h>
20#include <ctype.h>
21#include <stdarg.h>
22#include <stdio.h>
23
24char li_last_file[150];
25int li_last_line=0;
26
27// returns the length of the list
28int        li_length(li_object *o, li_environment *env)
29{
30  if (o->type()!=LI_LIST)
31    return 0;
32  else
33  {
34    int t=0;
35    while (o)
36    {
37      t++;
38      o=li_cdr(o, env);
39    }
40    return t;
41  }
42   
43}
44
45i4_bool li_is_number(li_object *o)
46{
47  return (i4_bool)(o->type()==LI_INT || o->type()==LI_FLOAT);
48}
49
50
51float li_get_float(li_object *o, li_environment *env)  // will convert int to float
52{
53  if (o->type()==LI_INT)
54    return li_int::get(o, env)->value();
55  else
56    return li_float::get(o, env)->value();
57}
58
59int li_get_int(li_object *o, li_environment *env)    // will convert float to int
60{
61  if (o->type()==LI_FLOAT)
62    return (int)li_float::get(o, env)->value();
63  else
64    return li_int::get(o, env)->value();
65}
66
67char *li_get_string(li_object *o, li_environment *env)
68{
69  return li_string::get(o, env)->value();
70}
71
72
73void li_skip_c_comment(char *&s)
74{
75  s+=2;
76  while (*s && (*s!='*' || *(s+1)!='/'))
77  {
78    if (*s=='/' && *(s+1)=='*')
79      li_skip_c_comment(s);
80    else s++;
81  }
82  if (*s) s+=2;
83}
84
85
86int li_read_token(char *&s, char *buffer)
87{
88  // skip space
89  while (*s==' ' || *s=='\t' || *s=='\n' || *s=='\r' || *s==26)
90  {
91    if (*s=='\n')
92      li_last_line++;
93    s++;
94  }
95 
96  if (*s==';')  // comment
97  {
98    while (*s && *s!='\n' && *s!=26)
99    {
100      if (*s=='\n')
101        li_last_line++;
102      s++;
103    }
104   
105    return li_read_token(s,buffer);
106  } else if  (*s=='/' && *(s+1)=='*')   // c style comment
107  {
108    li_skip_c_comment(s);
109    return li_read_token(s,buffer);   
110  }
111  else if (*s==0)
112    return 0;
113  else if (*s==')' || *s=='(' || *s=='\'' || *s=='`' || *s==',' || *s==26)
114  {
115    *(buffer++)=*(s++);
116    *buffer=0;
117  } else if (*s=='"')    // string
118  {
119    *(buffer++)=*(s++);          // don't read off the string because it
120    // may be to long to fit in the token buffer
121    // so just read the '"' so the compiler knows to scan the rest.
122    *buffer=0;
123  } else if (*s=='#')
124  {
125    *(buffer++)=*(s++);     
126    if (*s!='\'')
127      *(buffer++)=*(s++);     
128    *buffer=0;
129  } else
130  {
131    while (*s && *s!=')' && *s!='(' && *s!=' ' &&
132           *s!='\n' && *s!='\r' && *s!='\t' && *s!=';' && *s!=26)
133      *(buffer++)=*(s++);     
134    *buffer=0;
135  }
136  return 1;   
137}
138
139int li_streq(char *s1, char *s2)
140{
141  return strcmp(s1,s2)==0;
142}
143
144
145long li_str_token_len(char *st)
146{
147  long x=1;
148  while (*st && (*st!='"' || st[1]=='"'))
149  {
150    if (*st=='\\' || *st=='"') st++;   
151    st++; x++;
152  }
153  return x;
154}
155
156static i4_critical_section_class token_buf_lock;
157enum {MAX_LISP_TOKEN_LEN=512};
158static char li_token[MAX_LISP_TOKEN_LEN];  // assume all tokens will be < 512 characters
159
160
161li_object *li_locked_get_expression(char *&s, li_environment *env)
162{
163
164  li_object *ret=0;
165
166  if (!li_read_token(s,li_token))
167    return 0;
168  if (li_streq(li_token,"nil"))
169    return li_nil;
170  else if (li_token[0]=='T' && !li_token[1])
171    return li_true_sym;
172  else if (li_token[0]=='\'')                    // short hand for quote function
173    return new li_list(li_quote, new li_list(li_locked_get_expression(s, env), 0));   
174  else if (li_token[0]=='`')                    // short hand for backquote function
175    return new li_list(li_backquote, new li_list(li_locked_get_expression(s, env),0));
176  else if (li_token[0]==',')              // short hand for comma function
177    return new li_list(li_comma, new li_list(li_locked_get_expression(s, env), 0));
178  else if (li_token[0]=='(')                     // make a list of everything in ()
179  {
180    li_list *first=NULL,*cur=NULL,*last=NULL;   
181
182    int done=0;
183    do
184    {
185      char *tmp=s;
186      if (!li_read_token(tmp,li_token))           // check for the end of the list
187        li_error(env, "unexpected end of program");
188      if (li_token[0]==')')
189      {
190        done=1;
191        li_read_token(s,li_token);                // read off the ')'
192      }
193      else
194      {     
195        if (li_token[0]=='.' && !li_token[1])
196        {
197          if (!first)
198            li_error(env, "token '.' not allowed here : %s\n",s);             
199          else
200          {
201            li_read_token(s,li_token);              // skip the '.'
202            last->set_next(li_locked_get_expression(s, env));          // link the last cdr to
203            last=NULL;
204          }
205        } else if (!last && first)
206          li_error(env, "illegal end of dotted list\n");
207        else
208        {       
209          li_list *p=new li_list(li_locked_get_expression(s, env), 0);
210          if (last)
211            last->set_next(p);
212          else
213            first=p;
214          last=p;
215        }
216      }
217    } while (!done);
218
219    if (!first)
220      return li_nil;
221    else return first;
222
223  } else if (li_token[0]==')')
224    li_error(env, "mismatched ) at %s",s);
225  else if (isdigit(li_token[0]) || (li_token[0]=='-' && isdigit(li_token[1])))
226  {
227    int i=0,per=0,hex=0,x;
228   
229    if (li_token[0]=='0' && li_token[1]=='x')     // hex number
230    {
231      hex=1;
232      i+=2;
233    }
234       
235    for (; li_token[i] && (isdigit(li_token[i]) || li_token[i]=='.' || li_token[i]=='-'); i++)
236      if (li_token[i]=='.')
237        per=1;
238
239    if (per)
240    {
241      float y;
242      sscanf(li_token,"%f",&y);     
243      return new li_float(y);
244    }
245    else if (hex)
246    {
247      sscanf(li_token,"%x",&x);
248      return new li_int(x);
249    }
250    else
251    {
252      sscanf(li_token,"%d",&x);
253      return new li_int(x);
254    }
255  } else if (li_token[0]=='"')
256  {
257    li_string *r=new li_string(li_str_token_len(s));
258
259    char *start=r->value();
260
261    for (;*s && (*s!='"' || s[1]=='"');s++,start++)
262    {
263      if (*s=='\\')
264      {
265        s++;
266        if (*s=='n') *start='\n';
267        if (*s=='r') *start='\r';
268        if (*s=='t') *start='\t';
269        if (*s=='\\') *start='\\';
270      } else *start=*s;
271      if (*s=='"') s++;
272    }
273    *start=0;
274    s++;
275
276    return r;
277  } else if (li_token[0]=='#')
278  {
279    if (li_token[1]=='\\')
280    {
281      li_read_token(s,li_token);                   // read character name
282      if (li_streq(li_token,"newline"))
283        ret=new li_character('\n');
284      else if (li_streq(li_token,"space"))
285        ret=new li_character(' ');       
286      else
287        ret=new li_character(li_token[0]);       
288    }
289    else if (li_token[1]==0)                           // short hand for function
290      return new li_list(li_function_symbol, new li_list(li_locked_get_expression(s, env), 0));
291    else
292    {
293      li_error(env, "Unknown #\\ notation : %s\n",li_token);
294      exit(0);
295    }
296  } else
297    return li_get_symbol(li_token);
298
299  return ret;
300}
301
302// because we can only allow one thread to use the token buffer at a time
303// so we don't have to allocate it on the stack (because it's fairly recursive)
304// I lock access to the token buffer per thread
305li_object *li_get_expression(char *&s, li_environment *env)
306{
307  token_buf_lock.lock();
308  li_object *ret=li_locked_get_expression(s, env);
309  token_buf_lock.unlock();
310  return ret;
311}
312
313
314void lip(li_object *o)
315{
316  if (!o)
317  {
318    i4_debug->printf("(null object)\n");
319    return ;
320  }
321
322  if (!li_valid_object(o))
323  {
324    i4_debug->printf("(invalid object)\n");
325    return ;
326  }
327
328  li_get_type(o->type())->print(o, i4_debug);
329  i4_debug->printf("\n");
330}
331
332li_object *li_print(li_object *o, li_environment *env)
333{
334  li_object *ret=0;
335  while (o)
336  {
337    ret=li_eval(li_car(o,env),env);
338    lip(ret);
339    o=li_cdr(o,env);
340  }
341  return ret;
342}
343
344li_list *li_make_list(li_object *first, ...)
345{
346  va_list ap;
347  va_start(ap, first);
348 
349  li_list *ret=new li_list(first,0), *last;
350  last=ret;
351 
352  while (1)
353  {
354    li_object *o=va_arg(ap, li_object *);
355    if (o)
356    {
357      li_list *next=new li_list(o,0);
358      last->set_next(next);
359      last=next;
360    }
361    else
362    {
363      va_end(ap);
364      return ret;
365    }
366  }
367}
368
369
370
371li_object *li_get_fun(li_symbol *sym, li_environment *env)
372{
373  if (env)
374    return env->fun(sym);
375  else return sym->fun();
376}
377
378li_object *li_get_fun(char *sym, li_environment *env)
379{
380  return li_get_fun(li_get_symbol(sym),env);
381}
382
383
384li_object *li_eval(li_object *expression, li_environment *env)
385{
386  if (!expression)
387    return li_nil;
388   
389  int type=expression->type();
390  switch (type)
391  {   
392    case LI_SYMBOL :
393    {
394      li_object *v=li_get_value(li_symbol::get(expression,env), env);
395      if (!v)
396        li_error(env, "Symbol '%O' has no value", expression);
397      return v;
398
399    } break;
400
401    case LI_LIST :
402    {
403      li_list *o=li_list::get(expression,env);
404      li_symbol *sym=li_symbol::get(o->data(),env);
405      return li_call(sym, o->next(), env);
406    } break;
407
408    default :
409      return expression;
410      break;
411  }
412
413  return 0;
414}
415
416
417li_object *li_load(i4_file_class *fp, li_environment *env, i4_status_class *status)
418{
419  li_object *ret=0;
420  li_last_line=0;
421
422
423  int l=fp->size();
424
425  char *buf=(char *)i4_malloc(l+1,"");
426  buf[l]=0;
427  fp->read(buf,l);
428
429  char *s=buf;
430 
431
432  li_object *exp;
433  do
434  {
435    if (status)
436      status->update((s-buf)/(float)l);
437
438    exp=li_get_expression(s, env);
439    if (exp)
440      ret=li_eval(exp, env);   
441  } while (exp);
442
443  i4_free(buf);
444  return ret;
445}
446
447li_object *li_load(li_object *name, li_environment *env)
448{
449  return li_load(name, env, 0);
450}
451
452li_object *li_load(li_object *name, li_environment *env, i4_status_class *status)
453{
454  li_object *ret=0;
455
456  char old_file[256];
457  strcpy(old_file, li_last_file);
458  int old_line=li_last_line;
459 
460  li_gc();
461
462  while (name)
463  {
464    char *s=li_string::get(li_eval(li_car(name,env),env),env)->value();
465    strcpy(li_last_file, s);
466
467    i4_file_class *fp=i4_open(i4_const_str(s));
468    if (fp)
469    {
470      ret=li_load(fp, env, status);
471      delete fp;
472    }
473    else
474      i4_warning("li_load : file missing %s", s);
475
476    name=li_cdr(name,env);
477  }
478 
479  strcpy(li_last_file, old_file);
480  li_last_line=old_line;
481 
482
483  return ret;
484}
485
486li_object *li_read_eval(li_object *o, li_environment *env)
487{
488  char line[1000], *c=line;
489  int t=0;
490  i4_debug->printf("eval>");
491  do
492  {
493    if (i4_debug->read(c,1)!=1)
494      return 0;
495    t++;
496    c++;
497  } while (c[-1]!='\n' && t<998);
498 
499  *c=0;
500  c=line;
501  li_object *ret=li_eval(li_get_expression(c, env), env);
502  lip(ret);
503  return ret;
504}
505
506li_object *li_load(char *filename, li_environment *env, i4_status_class *status)
507{
508  return li_load(new li_list(new li_string(filename), 0), env, status);
509}
510
511void li_add_function(li_symbol *sym,
512                     li_function_type fun,
513                     li_environment *env)
514{
515  li_function *f=new li_function(fun);
516
517  if (env)
518    env->set_fun(sym, f);
519  else
520    sym->set_fun(f);
521}
522
523
524void li_add_function(char *sym_name, li_function_type fun, li_environment *env)
525{
526  li_add_function(li_get_symbol(sym_name), fun, env);
527}
528
529i4_bool li_get_bool(li_object *o, li_environment *env)
530{
531  if (!o) return i4_F;
532
533  li_symbol *s=li_symbol::get(o,env);
534
535  if (o==li_nil)
536    return i4_F;
537  else if (o==li_true_sym)
538    return i4_T;
539  else
540    li_error(env, "expecting T or nil, got %O", o);
541
542  return 0;
543}
544
545static inline int fmt_char(char c)
546{
547  if ((c>='a' && c<='z') || (c>='A' && c<='Z'))
548    return 1;
549  return 0;
550}
551
552static w8 li_recursive_error=0;
553
554void li_vprintf(i4_file_class *fp,
555                char *fmt,
556                va_list ap)
557{
558 
559  while (*fmt)
560  {
561    if (*fmt=='%')
562    {
563      char *fmt_end=fmt;
564      while (!fmt_char(*fmt_end) && *fmt_end) fmt_end++;
565      char f[10], out[500];
566      memcpy(f, fmt, fmt_end-fmt+1);
567      f[fmt_end-fmt+1]=0;
568      out[0]=0;
569
570      switch (*fmt_end)
571      {
572        case 'O' :
573        {
574          li_object *o=va_arg(ap,li_object *);
575          li_get_type(o->type())->print(o, fp);
576        } break;
577
578        case 'd' :
579        case 'i' :
580        case 'x' :
581        case 'X' :
582        case 'o' :
583          ::sprintf(out,f,va_arg(ap,int));
584          break;
585
586        case 'f' :
587        {
588          float fl=va_arg(ap, double);
589          ::sprintf(out,f,fl);
590        } break;
591
592        case 'g' :
593          ::sprintf(out,f,va_arg(ap,double));
594          break;
595
596        default :
597          ::sprintf(out,f,va_arg(ap,void *));
598          break;
599      }
600      fp->write(out, strlen(out));
601      fmt=fmt_end;
602      if (*fmt)
603        fmt++;
604    }
605    else
606    {
607      fp->write_8(*fmt);
608      fmt++;
609    }
610
611
612  }
613}
614
615
616void li_printf(i4_file_class *fp,
617               char *fmt,                   // typical printf format, with %o == li_object
618              ...)
619
620  va_list ap;
621  va_start(ap, fmt);
622  li_vprintf(fp, fmt, ap);
623  va_end(ap);
624
625}
626
627void li_error(li_environment *env,
628              char *fmt,
629              ...)
630{
631  if (!li_recursive_error)      // error shouldn't call error again!
632  {
633    li_recursive_error++;
634    i4_file_class *fp=i4_open("li_error.txt", I4_WRITE);
635
636    if (fp)
637    {
638      va_list ap;
639      va_start(ap, fmt);
640 
641      li_vprintf(fp, fmt, ap);
642      fp->printf("\nCall stack:\n");
643      if (env)
644        env->print_call_stack(fp);
645
646      fp->printf("\nlast file %s:%d", li_last_file, li_last_line);
647      delete fp;
648     
649
650      fp=i4_open("li_error.txt");
651      if (fp)
652      {
653        int size=fp->size();
654        char *b=(char *)i4_malloc(size+1,"");
655        fp->read(b, size);
656        b[size]=0;
657        delete fp;
658
659        i4_get_error_function_pointer(li_last_file, 0)(b);
660
661        i4_free(b);
662      }
663    }
664
665    li_recursive_error--;
666  } 
667}
668
669li_object *li_new(char *type_name, li_object *params, li_environment *env)
670{
671  li_symbol *s=li_find_symbol(type_name);
672  if (!s) return 0;
673
674  li_object *v=li_get_value(s, env);
675  if (!v || v->type()!=LI_TYPE) return 0;
676 
677  li_type_number type=li_type::get(v,env)->value();
678  return li_get_type(type)->create(params, env);
679}
680
681li_object *li_new(int type, li_object *params, li_environment *env)
682{
683  return li_get_type(type)->create(params, env);
684}
685
686li_object *li_call(li_symbol *val, li_object *params, li_environment *env)
687{
688  if (val)
689  {
690    li_symbol *old_fun=0;
691    li_object *old_args=0;
692    if (env)
693    {     
694      old_fun=env->current_function();
695      old_args=env->current_arguments();
696    }
697    else
698      env=new li_environment(env, i4_F);
699
700    env->current_function()=val;
701    env->current_arguments()=params;
702   
703   
704    li_object *ret=0;   
705    li_object *f=li_get_fun(val, env);
706    if (f)
707    {
708      li_function_type fun=li_function::get(f,env)->value();
709      if (fun)
710        ret=fun(params, env);     
711    }
712    else
713      li_error(env, "symbol %O has no function", val);
714   
715    if (old_fun)
716    {
717      env->current_function()=old_fun;
718      env->current_arguments()=old_args;
719    }
720
721    return ret;
722  }
723
724  return 0;
725}
726
727li_object *li_call(char *fun_name, li_object *params, li_environment *env)
728{
729  return li_call(li_get_symbol(fun_name), params, env);
730}
731
732li_object  *li_first(li_object *o, li_environment *env) { return li_car(o,env); }
733li_object  *li_second(li_object *o, li_environment *env) { return li_car(li_cdr(o,env),env); }
734li_object  *li_third(li_object *o, li_environment *env) { return li_car(li_cdr(li_cdr(o,env),env),env); }
735li_object  *li_fourth(li_object *o, li_environment *env)
736{ return li_car(li_cdr(li_cdr(li_cdr(o,env),env),env),env); }
737
738li_object  *li_fifth(li_object *o, li_environment *env)
739{ return li_car(li_cdr(li_cdr(li_cdr(li_cdr(o,env),env),env),env),env); }
740
741li_object  *li_nth(li_object *o, int x, li_environment *env)
742{ while (x--) o=li_cdr(o,env); return li_car(o,env); }
743
Note: See TracBrowser for help on using the repository browser.