source: abuse/tags/pd/macabuse/src/lcache.c @ 49

Last change on this file since 49 was 49, checked in by Sam Hocevar, 12 years ago
  • Imported original public domain release, for future reference.
  • Property svn:keywords set to Id
File size: 2.8 KB
Line 
1#include "lisp.hpp"
2#include "specs.hpp"
3#include "bus_type.hpp"
4#include "ramfile.hpp"
5
6
7long block_size(Cell *level)  // return size needed to recreate this block
8{
9  int ret;
10  if (!level) ret=0;    // NULL pointers don't need to be stored
11  else
12  {
13    int type=item_type(level);
14    if (type==L_CONS_CELL)
15    {
16        long t=0;
17        void *b=level;
18        for (;b && item_type(b)==L_CONS_CELL;b=CDR(b))
19        {
20          t+=sizeof(cons_cell);
21        }
22        if (b) t+=block_size(b);
23        for (b=level;b && item_type(b)==L_CONS_CELL;b=CDR(b))
24          t+=block_size(CAR(b));
25        ret=t;
26    } else if (type== L_NUMBER)
27    { ret=sizeof(lisp_number); }
28    else if (type==L_CHARACTER)
29    { ret=sizeof(lisp_character); }
30    else if (type==L_STRING)
31    {
32      ret=sizeof(lisp_string)+strlen(lstring_value(level))+1;
33      if (ret<8)
34        ret=8;
35    }
36    else if (type==L_POINTER)
37    { ret=sizeof(lisp_pointer); }
38    else ret=0;
39  }
40#ifdef WORD_ALLIGN
41  return (ret+3)&(~3);
42#else
43  return ret;
44#endif
45}
46
47
48
49void write_level(memory_file *fp, Cell *level)
50{
51  int type=item_type(level);
52  fp->write_byte(type);
53
54
55  switch (type)
56  {
57    case L_NUMBER :
58    { fp->write_long(lnumber_value(level)); } break;
59    case L_CHARACTER :
60    { fp->write_short(lcharacter_value(level)); } break;
61    case L_STRING :
62    { long l=strlen(lstring_value(level))+1;
63      fp->write_long(l);
64      fp->write(lstring_value(level),l);
65    } break;
66    case L_SYMBOL :
67    { fp->write_long((long)level); } break;
68    case L_CONS_CELL :
69    {
70      if (!level) fp->write_long(0);
71      else
72      {
73        long t=0;
74        void *b=level;
75        for (;b && item_type(b)==L_CONS_CELL;b=CDR(b)) t++;
76        if (b)
77        {
78          fp->write_long(-t);      // negative number means dotted list
79          write_level(fp,b);       // save end of dotted list     
80        }
81        else fp->write_long(t);
82
83        for (b=level;b && item_type(b)==L_CONS_CELL;b=CDR(b))   
84          write_level(fp,CAR(b));
85      }
86    } break;
87  }
88}
89
90Cell *load_block(memory_file *fp)
91{
92  int type=fp->read_byte();
93  switch (type)
94  {   
95    case L_NUMBER :
96    { return new_lisp_number(fp->read_long()); } break;
97    case L_CHARACTER :
98    { return new_lisp_character(fp->read_short()); } break;
99    case L_STRING :
100    { long l=fp->read_long();
101      lisp_string *s=new_lisp_string(l);
102      fp->read(lstring_value(s),l);
103      return s;
104    } break;
105    case L_SYMBOL :
106    { return (void *)fp->read_long(); } break;
107    case L_CONS_CELL :
108    {
109      long t=fp->read_long();
110      if (!t) return NULL;
111      else
112      {
113                                long x=abs(t);
114                                cons_cell *last,*first=NULL;
115                                while (x)
116                                {
117                                  cons_cell *c=new_cons_cell();
118                                  if (first)
119                                    last->cdr=c;
120                                  else first=c;
121                                  last=c;
122                                  x--;
123                                }
124                                if (t<0)       
125                                  last->cdr=load_block(fp);
126                                else last->cdr=NULL;
127                               
128                                for (last=first,x=0;x<abs(t);x++,last=(cons_cell *)last->cdr)       
129                                  last->car=load_block(fp);     
130                                return first;
131      }
132    }
133  }
134  return NULL;
135}
Note: See TracBrowser for help on using the repository browser.