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

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