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

Last change on this file since 80 was 80, checked in by Sam Hocevar, 11 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: 20.6 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 "memory/array.hh"
10#include "lisp/li_types.hh"
11#include "file/file.hh"
12#include "lisp/lisp.hh"
13#include "loaders/dir_save.hh"
14#include "loaders/dir_load.hh"
15#include <stdio.h>
16
17
18li_string::li_string(char *name)
19  : li_object(LI_STRING)
20{
21  int l=strlen(name)+1;
22  _name=(char *)i4_malloc(l,"");
23  memcpy(_name, name, l);
24}
25
26li_string::li_string(int len)
27  : li_object(LI_STRING)
28{
29  _name=(char *)i4_malloc(len,"");
30}
31
32li_string::li_string(const i4_const_str &str)
33  : li_object(LI_STRING)
34{
35  int len=str.length()+1;
36  _name=(char *)i4_malloc(len,"");
37  i4_os_string(str, _name, len);
38}
39
40
41
42void li_save_type(i4_file_class *fp, li_type_number type)
43{
44  fp->write_16(type);
45}
46
47li_type_number  li_load_type(i4_file_class *fp, li_type_number *type_remap)
48{
49  I4_ASSERT(type_remap, "call li_load_type_info before li_load_type");
50
51  return type_remap[fp->read_16()];
52}
53
54
55void li_save_object(i4_saver_class *fp, li_object *o, li_environment *env)
56{
57  if (!o)
58    fp->write_16(0);
59  else
60  {
61    li_save_type(fp, o->type());
62
63    int h;
64    if (o->type()>LI_TYPE)
65      h=fp->mark_size();
66
67    li_get_type(o->type())->save_object(fp, o, env);
68
69    if (o->type()>LI_TYPE)
70      fp->end_mark_size(h);
71  }
72}
73
74
75li_object *li_load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
76{
77  li_type_number old_type=fp->read_16(); 
78  li_type_number type=type_remap[old_type];
79 
80  if (old_type==0)
81    return 0;
82
83  w32 skip=0;
84  if (old_type>LI_TYPE)
85    skip=fp->read_32();
86  else if (type==0)
87    i4_error("huh?");   // shouldn't happen (please, please)
88
89  if (type)
90    return li_get_type(type)->load_object(fp, type_remap, env);
91  else if (type>0 && type<=LI_TYPE)
92  {
93    li_error(env, "type not found, but should be");
94    return 0;
95  }
96  else
97  {
98    fp->seek(fp->tell() + skip);
99    return 0;
100  }
101}
102
103class li_invalid_type_function : public li_type_function_table
104{
105  virtual void mark(li_object   *o, int set) { i4_error("marking invalid object"); }
106  virtual void free(li_object   *o) { i4_error("freeing invalid object"); }
107  virtual int equal(li_object  *o1, li_object *o2) 
108  { 
109    i4_error("comparing  invalid object");
110    return 0;
111  }
112
113  virtual void print(li_object  *o, i4_file_class *stream)   
114  { i4_error("printing invalid object"); }
115  virtual char *name() { i4_error("getting name for invalid object"); return 0;}
116
117  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
118  { li_error(env, "saving invalid object"); }
119
120  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
121  {
122    li_error(env, "loading invalid object");
123    return 0;
124  }
125
126};
127
128
129void li_symbol::free()
130{
131  i4_free(data);
132}
133
134
135
136class li_symbol_type_function : public li_type_function_table
137{
138  virtual void mark(li_object *o, int set)
139  {
140    li_symbol *s=(li_symbol *)o;
141    s->mark(set);
142
143    if (s->value())
144    {
145      if (set!=s->value()->is_marked())
146        li_get_type(s->value()->unmarked_type())->mark(s->value(), set);   
147    }
148
149    li_object *fun=s->fun();
150    if (fun)
151    {
152      if (set!=fun->is_marked())
153        li_get_type(fun->unmarked_type())->mark(fun, set);   
154    }
155
156    li_object *name=s->name();
157    if (set!=name->is_marked())
158      li_get_type(name->unmarked_type())->mark(name, set);   
159  }
160
161  virtual void free(li_object   *o)
162  {
163    li_symbol::get(o,0)->free();
164  }
165 
166  virtual void print(li_object  *o, i4_file_class *stream)   
167  { 
168    li_symbol *s=li_symbol::get(o,0);
169    char *name=s->name()->value();   
170    stream->write(name, strlen(name));
171  }
172  virtual char *name() { return "symbol"; }
173
174  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
175  {
176    li_symbol *s=li_symbol::get(o,env);
177    char *name=s->name()->value();
178    int name_len=strlen(name)+1;
179
180    fp->write_16(name_len);
181    fp->write(name, name_len);
182  }
183
184  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
185                                 li_environment *env)
186  {
187    char buf[200];
188    int len=fp->read_16();
189    if (len>200)
190      li_error(env, "symbol name too long");
191    fp->read(buf, len);
192    return li_get_symbol(buf);
193  }
194};
195
196
197
198char *li_get_type_name(li_type_number type)
199{
200  return li_get_type(type)->name();
201}
202
203li_string::li_string(i4_file_class *fp) : li_object(LI_STRING)
204{
205  int l=fp->read_32();
206  _name=(char *)i4_malloc(l,"");
207  fp->read(_name, l);
208}
209
210class li_string_type_function : public li_type_function_table
211{
212  virtual void free(li_object   *o)
213  {
214    i4_free(li_string::get(o,0)->value());
215  }
216
217  virtual void print(li_object  *o, i4_file_class *stream)   
218  {
219    stream->printf("\"%s\"", li_string::get(o,0)->value());
220  }
221
222  virtual int equal(li_object  *o1, li_object *o2) 
223  {   
224    return (strcmp(li_string::get(o1,0)->value(), li_string::get(o2,0)->value())==0);
225  }
226
227  virtual char *name() { return "string"; }
228
229  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
230  {
231    char *s=li_string::get(o,env)->value();
232    int l=strlen(s)+1;
233    fp->write_32(l);
234    fp->write(s,l);
235  }
236
237  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
238  {
239    return new li_string(fp);
240  }
241
242};
243
244
245
246class li_int_type_function : public li_type_function_table
247{
248  virtual int equal(li_object  *o1, li_object *o2)
249  {
250    return li_int::get(o1,0)->value()==li_int::get(o2, 0)->value();
251  }
252
253  virtual void print(li_object  *o, i4_file_class *stream)   
254  {
255    stream->printf("%d", li_int::get(o,0)->value());
256  }
257
258  virtual char *name() { return "int"; }
259
260  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
261  {
262    fp->write_32(li_int::get(o,0)->value());
263  }
264
265  virtual li_object *load_object(i4_loader_class *fp,  li_type_number *type_remap,
266                                 li_environment *env)
267  {
268    return new li_int(fp->read_32());
269  }
270   
271
272};
273
274
275class li_type_type_function : public li_type_function_table
276{
277  virtual int equal(li_object  *o1, li_object *o2) 
278  {
279    return li_int::get(o1,0)->value()==li_int::get(o2,0)->value();
280  }
281
282  virtual void print(li_object  *o, i4_file_class *stream)   
283  {
284    stream->printf("type-%s", li_get_type(li_type::get(o,0)->value())->name());
285  }
286
287  virtual char *name() { return "type"; }
288
289  virtual void save_object(i4_saver_class *fp, li_object *o,
290                           li_environment *env)
291  {
292    li_save_type(fp, li_type::get(o,env)->value());
293  }
294
295  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
296                                 li_environment *env)
297  {
298    int new_type=li_load_type(fp, type_remap);
299    if (new_type)
300      return new li_type(new_type);
301    else
302      return 0;
303  }
304
305};
306
307
308
309class li_float_type_function : public li_type_function_table
310{
311  virtual int equal(li_object  *o1, li_object *o2) 
312  { return li_float::get(o1,0)->value()==li_float::get(o2,0)->value(); }
313
314  virtual void print(li_object  *o, i4_file_class *stream)   
315  {
316    char buf[200], dec=0;
317    sprintf(buf, "%f", li_float::get(o,0)->value());
318   
319    for (char *c=buf; *c; c++)
320      if (*c=='.') dec=1;
321   
322    if (dec)
323    {
324      while (buf[strlen(buf)-1]=='0')
325        buf[strlen(buf)-1]=0;
326   
327      if (buf[strlen(buf)-1]=='.')
328        buf[strlen(buf)-1]=0;
329    }
330
331
332    stream->write(buf,strlen(buf));
333  }
334
335  virtual char *name() { return "float"; }
336
337  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
338  {
339    fp->write_float(li_float::get(o,env)->value());
340  }
341
342  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
343                                 li_environment *env)
344  {
345    return new li_float(fp->read_float());
346  }
347
348};
349
350
351class li_character_type_function : public li_type_function_table
352{
353  virtual int equal(li_object  *o1, li_object *o2) 
354  {
355    return li_character::get(o1,0)->value()==li_character::get(o2,0)->value();
356  }
357
358  virtual void print(li_object  *o, i4_file_class *stream)   
359  {
360    stream->printf("#%c",li_character::get(o,0)->value());
361  }
362
363  virtual char *name() { return "character"; }
364
365  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
366  {
367    fp->write_16(li_character::get(o,env)->value());
368  }
369
370  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
371                                 li_environment *env)
372  {
373    return new li_character(fp->read_16());
374  }
375
376};
377
378
379
380class li_list_type_function : public li_type_function_table
381{
382  virtual void mark(li_object   *o, int set)
383  {
384    if (o->is_marked() && set)
385      return ;
386
387    li_list *l=(li_list *)o;
388    if (l->data())
389    {
390      for (li_list *p=l; p;)
391      {
392        p->mark(set);
393        if (p->data())
394        {
395          if (set!=p->data()->is_marked())
396            li_get_type(p->data()->unmarked_type())->mark(p->data(), set);
397
398          if (p->next() && (set!=p->next()->is_marked()))
399          {
400            if (p->next()->unmarked_type()==LI_LIST)
401              p=(li_list *)p->next();
402            else
403            {
404              li_get_type(p->next()->unmarked_type())->mark(p->next(), set);
405              p=0;
406            }
407          } else p=0;
408        }
409        else p=0;
410
411      }
412    }
413  }
414 
415  virtual void free(li_object   *o)
416  {
417    li_list *l=(li_list *)o;
418    l->cleanup();
419
420  }
421
422  virtual int equal(li_object  *o1, li_object *o2) 
423  {
424    if (o1==o2) return 1;
425    li_list *p1=li_list::get(o1,0), *p2=li_list::get(o2,0);
426
427    for (;p1;)
428    {
429      if (!o2) return 0;
430
431      if (p1->data()->type() != p2->data()->type()) return 0;
432
433      if (li_get_type(p1->data()->type())->equal(p1->data(), p2->data())==0)  return 0;
434       
435      if (p1->next()->type()==LI_LIST)
436      {
437        if (p2->next()->type()!=LI_LIST)   return 0;
438        p1=(li_list *)p1->next();
439        p2=(li_list *)p2->next();
440      }
441      else if (p1->next()->type()!=p2->next()->type()) return 0;
442      else return li_get_type(p1->next()->type())->equal(p1->next(), p2->next());
443    }
444
445    if (!p2) return 1;
446    else return 0;
447  }
448
449
450  virtual void print(li_object  *o, i4_file_class *stream)   
451  {
452    stream->write_8('(');
453    li_list *p=li_list::get(o,0);
454    o->mark(1);          // mark to prevent recursive prints
455
456    for (; p; )
457    { 
458      li_get_type(p->data()->type())->print(p->data(), stream);
459
460      if (p->next())
461      {
462        if (p->next()->type()!=LI_LIST)
463        {
464          stream->write(" . ",3);
465          li_get_type(p->next()->type())->print(p->next(), stream);
466          p=0;
467        }
468        else
469        {
470          p=(li_list *)p->next();
471          stream->write_8(' ');
472        }
473      }
474      else p=0;
475    }
476
477    o->mark(0);
478
479    stream->write_8(')');
480  }
481
482  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
483  {
484    int t=0;
485    int last_is_cons=0;
486    li_list *l;
487    for (l=li_list::get(o,env); l;)
488    {
489      t++;
490      if (t>2000000)
491        li_error(env, "list is really big : trying to save a circular structure doesn't work");
492
493      li_object *next=l->next();
494      if (next)
495      {
496        if (next->type()!=LI_LIST)
497        {
498          l=0;
499          last_is_cons=0;
500        }
501        else l=(li_list *)next;
502      }
503      else l=0;
504    }
505
506
507    fp->write_32(t);
508
509    if (last_is_cons)
510      fp->write_8(1);
511    else
512      fp->write_8(0);
513
514    for (l=li_list::get(o, env); l;)
515    {
516      li_object *data=l->data();
517
518      li_save_object(fp, data, env);
519
520      li_object *next=l->next();
521      if (next)
522      {
523        if (next->type()==LI_LIST)
524          l=(li_list *)next;
525        else
526        {
527          li_save_object(fp, next, env);
528          l=0;
529        }
530      } else l=0;
531    }
532  }
533
534  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
535                                 li_environment *env)
536  {
537    int t=fp->read_32();
538    int last_is_cons=fp->read_8();
539    li_list *last=0, *first=0;
540
541    for (int i=0; i<t; i++)
542    {
543      li_object *data=li_load_object(fp, type_remap, env);
544      li_list *l=new li_list(data, 0);
545      if (!first)
546        first=l;
547      else
548        last->set_next(l);
549      last=l;
550    }
551
552    if (last_is_cons)
553      last->set_next(li_load_object(fp,type_remap,env));
554
555    return first;
556  }
557
558
559  virtual char *name() { return "list"; }
560};
561
562
563
564
565
566class li_function_type_function : public li_type_function_table
567{
568  virtual void print(li_object  *o, i4_file_class *stream)
569  {
570    stream->printf("#(compiled function @ 0x%x)", (long)(li_function::get(o,0)->value()));
571  }
572
573  virtual char *name() { return "function"; }
574
575  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
576  {
577    fp->write_16(li_type::get(o,env)->value());
578  }
579
580  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
581  {
582    int t=type_remap[fp->read_16()];
583    if (t)
584      return new li_type(t);
585    else
586      return 0;
587  }
588
589};
590
591
592li_symbol *&li_environment::current_function()
593{
594  return data->current_function;
595}
596
597li_object *&li_environment::current_arguments()
598{
599  return data->current_args;
600}
601
602void li_environment::print_call_stack(i4_file_class *fp)
603{
604  li_symbol *s=current_function();
605  li_object *o=current_arguments();
606
607  if (s && o)
608    li_printf(fp, "%O %O", s,o);
609  else if (s)
610    li_printf(fp, "%O %O", s);
611
612  if (data->next)
613    data->next->print_call_stack(fp);
614}
615
616
617li_object *li_environment::value(li_symbol *s)
618{
619  for (value_data *p=data->value_list; p; p=p->next)
620    if (p->symbol==s)
621      return p->value;
622
623  if (data->next)
624    return data->next->value(s);
625
626  return s->value();
627}
628
629
630li_object *li_environment::fun(li_symbol *s)
631{
632  for (fun_data *p=data->fun_list; p; p=p->next)
633    if (p->symbol==s)
634      return p->fun;
635
636  if (data->next)
637    return data->next->value(s);
638
639  return s->fun();
640}
641
642void li_environment::set_value(li_symbol *s, li_object *value)
643{
644  if (data->local_namespace)
645  {
646    for (value_data *p=data->value_list; p; p=p->next)
647      if (p->symbol==s)
648        p->value=value;
649 
650    value_data *v=new value_data;
651    v->symbol=s;
652    v->value=value;
653    v->next=data->value_list;
654    data->value_list=v;
655  }
656  else if (data->next)
657    data->next->set_value(s,value);
658  else
659    s->set_value(value);
660}
661
662
663void li_environment::set_fun(li_symbol *s, li_object *fun)
664{
665  if (data->local_namespace)
666  {
667    for (fun_data *p=data->fun_list; p; p=p->next)
668      if (p->symbol==s)
669        p->fun=fun;
670 
671    fun_data *f=new fun_data;
672    f->symbol=s;
673    f->fun=fun;
674    f->next=data->fun_list;
675    data->fun_list=f;
676  }
677  else if (data->next)
678    data->next->set_fun(s, fun);
679  else
680    s->set_fun(fun);
681}
682
683
684void li_environment::mark(int set)
685{
686  li_object::mark(set);
687
688  for (value_data *v=data->value_list; v; v=v->next)
689    if (set!=v->value->is_marked())
690      li_get_type(v->value->unmarked_type())->mark(v->value,set);
691
692  for (fun_data *f=data->fun_list; f; f=f->next)
693    if (set!=f->fun->is_marked())
694      li_get_type(f->fun->unmarked_type())->mark(f->fun,set);
695
696  if (data->next && data->next->is_marked()!=set)
697    li_get_type(LI_ENVIROMENT)->mark(data->next, set);
698}
699
700void li_environment::free()
701{
702  for (value_data *v=data->value_list; v; )
703  {   
704    value_data *last=v;
705    v=v->next;
706    delete last;
707  }
708
709  for (fun_data *f=data->fun_list; f; )
710  {   
711    fun_data *last=f;
712    f=f->next;
713    delete last;
714  }
715
716  delete data;
717}
718
719void li_environment::print(i4_file_class *s)
720{
721  s->printf("#env-(syms=");
722
723  for (value_data *v=data->value_list; v; v=v->next)
724  {
725    s->write_8('(');
726    li_get_type(v->symbol->type())->print(v->symbol, s);
727    s->write_8(' ');
728    li_get_type(v->value->type())->print(v->value,  s);   
729    s->write_8(')');
730  }
731
732  s->printf("funs=");
733  for (fun_data *f=data->fun_list; f; f=f->next)
734  {
735    s->write_8('(');
736    li_get_type(f->symbol->type())->print(f->symbol, s);
737    s->write_8(' ');
738    li_get_type(f->fun->type())->print(f->fun,  s);   
739    s->write_8(')');
740  }
741  s->write_8(')');
742
743}
744
745
746
747class li_environment_type_function : public li_type_function_table
748{
749public:
750  virtual void mark(li_object   *o, int set)   { ((li_environment *)o)->mark(set); }
751  virtual void free(li_object   *o) {  li_environment::get(o,0)->free();  }
752  virtual void print(li_object  *o, i4_file_class *s) { li_environment::get(o,0)->print(s); }
753  virtual char *name() { return "environment"; }
754
755 
756  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
757  { li_error(env, "cannot be saved"); }
758
759  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
760  {
761    li_error(env, "cannot be loaded");
762    return 0;
763  }
764
765};
766
767
768
769class li_type_manager_class : public i4_init_class
770{
771
772public:
773  i4_array<li_type_function_table *> table;
774
775  int add(li_type_function_table *type_functions,
776          li_environment *env=0,
777          int anon=0)
778
779  {
780    li_type_number old_type=0, new_type=table.size();   
781
782    if (!anon)
783    {
784      li_symbol *sym=li_get_symbol(type_functions->name());
785      if (sym->value() && sym->value()->type()==LI_TYPE) 
786      {
787        old_type=li_type::get(sym->value(), env)->value();
788        i4_warning("attempt to reassign type %s ignored", type_functions->name());
789        delete type_functions;
790        return old_type;
791      }
792     
793      li_set_value(sym, new li_type(new_type), env);
794    }
795
796    table.add(type_functions);
797
798   
799    return new_type;
800  }
801
802  li_type_manager_class() : table(0,32) {}
803
804  void remove(int type_num)
805  {
806    delete table[type_num];
807    table[type_num]=0;
808  }
809
810  li_type_function_table *get(int num)
811  {
812    return table[num];
813  }
814
815  int init_type() { return I4_INIT_TYPE_LISP_BASE_TYPES; }
816  void init()
817  {
818    li_invalid_type_function *invalid=new li_invalid_type_function; 
819    for (int i=0; i<LI_LAST_TYPE; i++)
820      add(invalid,0,1);
821   
822    table[LI_SYMBOL]=new li_symbol_type_function;
823    table[LI_STRING]=new li_string_type_function;
824    table[LI_INT]=new li_int_type_function;
825    table[LI_FLOAT]=new li_float_type_function;
826    table[LI_LIST]=new li_list_type_function;
827   
828    table[LI_CHARACTER]=new li_character_type_function;
829    table[LI_FUNCTION]=new li_function_type_function;
830    table[LI_ENVIROMENT]=new li_environment_type_function;
831    table[LI_TYPE]=new li_type_type_function;
832  }
833
834  int find(char *name)
835  {
836    for (int i=1; i<table.size(); i++)
837      if (strcmp(table[i]->name(), name)==0)
838        return i;
839
840    return 0;
841  }
842
843};
844
845static li_type_manager_class li_type_man;
846
847int li_add_type(li_type_function_table *type_functions,   // return type number for type
848                li_environment *env,
849                int anon)
850
851{
852  return li_type_man.add(type_functions, env, anon);
853}
854
855void li_remove_type(int type_num)
856{
857  li_type_man.remove(type_num);
858}
859
860void li_cleanup_types()
861{
862  li_type_man.table.uninit();
863}
864
865li_type_function_table *li_get_type(li_type_number type_num)
866{
867  return li_type_man.get(type_num);
868}
869
870
871
872li_type_number li_find_type(char *name, li_environment *env)
873{
874  li_symbol *s=li_find_symbol(name);
875  if (s)
876    return li_type::get(li_get_value(s, env),env)->value();
877  else
878    return 0;
879}
880
881li_type_number li_find_type(char *name, li_environment *env, li_type_number &cache_to)
882{
883  if (cache_to)
884    return cache_to;
885  else
886  {
887    cache_to=li_type::get(li_get_value(li_get_symbol(name), env), env)->value();
888    return cache_to;
889  }
890}
891
892
893
894i4_bool li_valid_type(li_type_number type_number)
895{
896  return type_number>=0 && type_number<li_type_man.table.size() &&
897    li_type_man.table[type_number]!=0;
898}
899
900int li_max_types()
901{
902  return li_type_man.table.size();
903}
Note: See TracBrowser for help on using the repository browser.