home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / ABUSESRC.ZIP / AbuseSrc / macabuse / src / lcache.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-05-20  |  3.0 KB  |  136 lines
  1. #include "lisp.hpp"
  2. #include "specs.hpp"
  3. #include "bus_type.hpp"
  4. #include "ramfile.hpp"
  5.  
  6.  
  7. long 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.  
  49. void 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.  
  90. Cell *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. }
  136.