home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / CONTRIB / GNU-COMM / GCL-1.0 / GCL-1 / gcl-1.0 / c / fasdump.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  33.1 KB  |  1,469 lines
  1.  /* Copyright William F. Schelter  All Rights Reserved.
  2.  
  3.    Utility for writing out lisp objects and reading them in:
  4.    Basically it attempts to write out only those things which could
  5.    be written out using princ and reread.   It just uses less space
  6.    and is faster.
  7.    
  8.  
  9.    Primitives for dealing with a `fasd stream'.
  10.    Such a stream is really an array containing some state and a lisp file stream.
  11.    Note that having *print-circle* == nil wil make this faster.  gensyms will
  12.    still be dumped correctly in that case.
  13.    
  14.    open_fasd
  15.    write_fasd_top
  16.    read_fasd_top
  17.    close_fasd
  18.    
  19.    */
  20.  
  21.  
  22.  
  23. #ifndef FAT_STRING
  24. #include "include.h"
  25. #endif
  26.  
  27.  
  28. object coerce_stream();
  29. object fasd_patch_sharp();
  30.  
  31. object siVPinit;
  32. static int needs_patching;
  33.  
  34.  
  35. struct fasd {
  36.   object stream;   /* lisp object of type stream */
  37.   object table;  /* hash table used in dumping or vector on input*/
  38.   object eof;      /* lisp object to be returned on coming to eof mark */
  39.   object direction;    /* holds Cnil or Kinput or Koutput */
  40.   object package;  /* the package symbols are in by default */
  41.   object index;     /* integer.  The current_dump index on write  */
  42.   object filepos;   /* nil or the position of the start */ 
  43.   object table_length; /*    On read it is set to the size dump array needed
  44.              or 0
  45.              */
  46.   object evald_items;  /* a list of items which have been eval'd and must
  47.               not be walked by fasd_patch_sharp */
  48. };
  49.  
  50. struct fasd current_fasd;
  51.  
  52.  
  53. enum circ_ind {
  54.   LATER_INDEX,
  55.   NOT_INDEXED,
  56.   FIRST_INDEX,
  57.   };
  58.  
  59. enum dump_type {
  60.   d_nil,         /* dnil: nil */
  61.   d_eval_skip,        /* deval o1: evaluate o1 after reading it */
  62.   d_delimiter,   /* occurs after d_list,d_general and d_new_indexed_items */
  63.   d_enter_vector,      /* d_enter_vector o1 o2 .. on d_delimiter , make a cf_data with
  64.             this length.   Used internally by gcl.  Just make
  65.             an array in other lisps */
  66.   d_cons,        /* d_cons o1 o2: (o1 . o2) */
  67.   d_dot,
  68.   d_list,    /* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on
  69.         for (o1 o2       . on)
  70.         or d_list,o1,o2, ... ,on,d_delimiter  for (o1 o2 ...  on)
  71.           */
  72.   d_list1,   /* nil terminated length 1  d_list1,o1   */
  73.   d_list2,    /* nil terminated length 2 */
  74.   d_list3,
  75.   d_list4,
  76.   d_eval,
  77.   d_short_symbol,
  78.   d_short_string,
  79.   d_short_fixnum,
  80.   d_short_symbol_and_package,
  81.   d_bignum,
  82.   d_fixnum,
  83.   d_string,
  84.   d_objnull,
  85.   d_structure,
  86.   d_package,
  87.   d_symbol,
  88.   d_symbol_and_package,
  89.   d_end_of_file,
  90.   d_standard_character,
  91.   d_vector,
  92.   d_array,
  93.   d_begin_dump,
  94.   d_general_type,
  95.   d_sharp_equals,              /* define a sharp */
  96.   d_sharp_value,
  97.   d_sharp_value2,
  98.   d_new_indexed_item,
  99.   d_new_indexed_items,
  100.   d_reset_index,
  101.   d_macro,
  102.   d_reserve1,
  103.   d_reserve2,
  104.   d_reserve3,
  105.   d_reserve4,
  106.   d_indexed_item3,       /* d_indexed_item3 followed by 3bytes to give index */
  107.   d_indexed_item2,        /* d_indexed_item2 followed by 2bytes to give index */
  108.   d_indexed_item1,
  109.   d_indexed_item0      /* This must occur last ! */
  110.         
  111. };
  112.  
  113. /* set whole structures!  */
  114. #define SETUP_FASD_IN(fd) do{ \
  115.   fas_stream= (fd)->stream->sm.sm_fp; \
  116.   dump_index =   fix((fd)->index) ; \
  117.   current_fasd= * (fd);}while(0)
  118.  
  119. #define SAVE_CURRENT_FASD \
  120.    struct fasd old_fd; \
  121.    int old_dump_index = dump_index; \
  122.    FILE *old_fas_stream = fas_stream; \
  123.    int old_needs_patching = needs_patching; \
  124.    old_fd = current_fasd;
  125.  
  126.  
  127. #define  RESTORE_FASD \
  128.     current_fasd =old_fd ; \
  129.     dump_index= old_dump_index ; \
  130.     needs_patching = old_needs_patching ; \
  131.     fas_stream = old_fas_stream
  132.   
  133.   
  134. #define FASD_SHARP_LIMIT 250  /* less than short_max */
  135. #define SETUP_FASD_OUT(fasd) SETUP_FASD_IN(fasd)
  136.  
  137. #define dump_hash_table (current_fasd.table)
  138.  
  139. #define SIZE_D_CODE 8
  140. #define SIZE_BYTE 8
  141. #define SIZE_SHORT ((2*SIZE_BYTE) - SIZE_D_CODE)
  142. /* this is not! the maximum short !!  It is shorter */
  143. #define SHORT_MAX ((1<< SIZE_SHORT) -1)
  144.  
  145.  
  146. /* given SHORT extract top code (say 4 bits) and bottom byte */
  147. #define TOP(i) (i >> SIZE_BYTE)
  148. #define BOTTOM(i) (i &  ~(~0 << SIZE_BYTE))
  149.  
  150. #define FASD_VERSION 2
  151.  
  152. FILE *fas_stream;
  153. int dump_index;
  154. struct htent *gethash();
  155. void read_fasd1();
  156. object extended_read();
  157.  
  158. #define DEBUG
  159.  
  160. #ifdef DEBUG
  161.  
  162. #define PUT(x) putc1((char)x,fas_stream)
  163. #define GET() getc1()
  164. #define FWRITE fwrite1
  165. #define FREAD fread1
  166.  
  167. char *dump_type_names[]={ "d_nil",
  168.      "d_eval_skip",
  169.      "d_delimiter",
  170.      "d_enter_vector",
  171.      "d_cons",
  172.      "d_dot",
  173.      "d_list",
  174.      "d_list1",
  175.      "d_list2",
  176.      "d_list3",
  177.      "d_list4",
  178.      "d_eval",
  179.      "d_short_symbol",
  180.      "d_short_string",
  181.      "d_short_fixnum",
  182.      "d_short_symbol_and_package",
  183.      "d_bignum",
  184.      "d_fixnum",
  185.      "d_string",
  186.      "d_objnull",
  187.      "d_structure",
  188.      "d_package",
  189.      "d_symbol",
  190.      "d_symbol_and_package",
  191.      "d_end_of_file",
  192.      "d_standard_character",
  193.      "d_vector",
  194.      "d_array",
  195.      "d_begin_dump",
  196.      "d_general_type",
  197.      "d_sharp_equals",
  198.      "d_sharp_value",
  199.       "d_sharp_value2",
  200.      "d_new_indexed_item",
  201.      "d_new_indexed_items",
  202.      "d_reset_index",
  203.      "d_macro",
  204.      "d_reserve1",
  205.      "d_reserve2",
  206.      "d_reserve3",
  207.      "d_reserve4",
  208.      "d_indexed_item3",
  209.      "d_indexed_item2",
  210.      "d_indexed_item1",
  211.      "d_indexed_item0"};
  212.  
  213. int debug;
  214. print_op(i)
  215. {if (debug)
  216.    {if (i < d_indexed_item0 & i >= 0)
  217.        {printf("\n<%s>",dump_type_names[i]);}
  218.    else {printf("\n<indexed_item0:%d>",i -d_indexed_item0);}}
  219.  return i;
  220. }
  221.  
  222. #define PUTD(str,i) putd(str,i)
  223. putd(str,i)
  224. char *str;
  225.   int i;
  226. {if (debug)
  227.    {printf("{");
  228.     printf(str,i);
  229.     printf("}");}
  230.  putc(i,fas_stream);}
  231.  
  232. putc1(x)
  233. int x;
  234. {  if (debug) printf("(%x,%d,%c)",x,x,x);
  235.    putc(x,fas_stream);
  236.    fflush(stdout);
  237.  }
  238.  
  239. getc1()
  240. { int x;
  241.    x= getc(fas_stream);
  242.   if (debug) printf("(%x,%d,%c)",x,x,x);
  243.   fflush(stdout);
  244.   return x;
  245.  }
  246.  
  247. fread1(p,n1,n2,st)
  248.      FILE* st;
  249.      char *p;
  250.      int n1;
  251.      int n2;
  252. {int i,j;
  253.  j=fread(p,n1,n2,st);
  254.  if(debug)
  255.  {printf("[");
  256.   n1=n1*n2;
  257.   for(i=0;i<n1; i++)
  258.     putc(p[i],stdout);
  259.   printf("]");
  260.   fflush(stdout);}
  261.     return j;
  262.  
  263. }
  264.  
  265.    
  266.  
  267.  
  268.  
  269. fwrite1(p,n1,n2,st)
  270.      FILE* st;
  271.      char *p;
  272.      int n1;
  273.      int n2;
  274. {int i,j;
  275.  j=fwrite(p,n1,n2,st);
  276.  if(debug)
  277.  {printf("[");
  278.   n1=n1*n2;
  279.   for(i=0;i<n1; i++)
  280.     putc(p[i],stdout);
  281.   printf("]");}
  282.     return j;
  283. }
  284.  
  285. int char_read;
  286. #define GET_OP() (print_op(getc(fas_stream)))
  287. #define PUT_OP(x) fputc(print_op(x),fas_stream)
  288.  
  289. #define DP(sw)  sw   /*  if (debug) {printf("\ncase sw");} */
  290. #define GETD(str) getd(str)
  291.  
  292. getd(str)
  293.  char *str;
  294. { int i = getc(fas_stream);
  295.  if(debug){
  296.    printf("{");
  297.    printf(str,i);
  298.    printf("}");}
  299.   return i;}
  300. #define DPRINTF(a,b)  do{if(debug) printf(a,b);} while(0)
  301. #else
  302. #define PUT(x) putc((char)x,fas_stream)
  303. #define GET() getc(fas_stream)
  304. #define GET_OP GET
  305. #define PUT_OP PUT
  306. #define FWRITE fwrite
  307. #define FREAD fread
  308. #define DP(sw)  sw
  309. #define PUTD(a,b) PUT(b)
  310. #define GETD(a) GET()
  311. #define DPRINTF(a,b)  
  312.  
  313. #endif
  314.  
  315.  
  316.       
  317. #define D_TYPE_OF(byt) \
  318.   ((enum dump_type )((unsigned int) byt & ~(~0 << SIZE_D_CODE)))
  319.  
  320. /* this field may be the top of a short for length, or part of an extended
  321.    code */
  322. #define E_TYPE_OF(byt) ((unsigned int) byt >> (SIZE_D_CODE))
  323.   /* takes two bytes and reconstructs the SIZE_SHORT int from them after
  324.      dropping the code */
  325.  
  326.  
  327. /* takes two bytes i and j and returns the SHORT associated */ 
  328. #define LENGTH(i,j) MAKE_SHORT(E_TYPE_OF(i),(j))
  329.  
  330. #define MAKE_SHORT(top,bot) (((top)<< SIZE_BYTE) + (bot))
  331.  
  332. #define READ_BYTE1() getc(fas_stream)
  333.  
  334. #define GET4(varx ) \
  335.  do{int  var=READ_BYTE1();  \
  336.    var |=  (READ_BYTE1() << SIZE_BYTE); \
  337.    var |=  (READ_BYTE1() << (2*SIZE_BYTE)); \
  338.    var |=  (READ_BYTE1() << (3*SIZE_BYTE)); \
  339.    DPRINTF("{4byte:varx= %d}", var); \
  340.      varx=var;} while (0)
  341.  
  342. #define GET2(varx ) \
  343.  do{int  var=READ_BYTE1();  \
  344.    var |=  (READ_BYTE1() << SIZE_BYTE); \
  345.      DPRINTF("{2byte:varx= %d}", var); \
  346.      varx=var;} while (0)
  347.  
  348. #define GET3(varx ) \
  349.  do{int  var=READ_BYTE1();  \
  350.    var |=  (READ_BYTE1() << SIZE_BYTE); \
  351.    var |=  (READ_BYTE1() << (2*SIZE_BYTE)); \
  352.           DPRINTF("{3byte:varx= %d}", var); \
  353.      varx=var;} while (0)
  354.  
  355.  
  356.  
  357. #define MASK ~(~0 << 8)
  358. #define WRITE_BYTEI(x,i)  putc((((x) >> (i*SIZE_BYTE)) & MASK),fas_stream)
  359.  
  360. #define PUT4(varx ) \
  361.  do{int var= varx ; \
  362.      DPRINTF("{4byte:varx= %d}", var); \
  363.        WRITE_BYTEI(var,0); \
  364.      WRITE_BYTEI(var,1); \
  365.      WRITE_BYTEI(var,2); \
  366.      WRITE_BYTEI(var,3);} while(0)
  367.  
  368. #define PUT2(var ) \
  369.  do{int v=var; \
  370.      DPRINTF("{2byte:var= %d}", v); \
  371.        WRITE_BYTEI(v,0); \
  372.      WRITE_BYTEI(v,1); \
  373.      } while(0)
  374.  
  375. #define PUT3(var ) \
  376.  do{int v=var; \
  377.      DPRINTF("{3byte:var= %d}", v); \
  378.        WRITE_BYTEI(v,0); \
  379.      WRITE_BYTEI(v,1); \
  380.        WRITE_BYTEI(v,2); \
  381.      } while(0)
  382.  
  383.  
  384.  
  385.  
  386.   /* constructs the first byte containing ecode and top
  387.      top either stands for something in extended codes, or for something
  388.      the top part of a SIZE_SHORT int
  389.    */
  390. #define MAKE_CODE(CODE,Top) \
  391.   ((unsigned int)(CODE) | ((unsigned int)(Top) <<  SIZE_D_CODE))
  392.  
  393.  
  394. /* write out two bytes encoding the enum d_code  CODE and SHORT SH. */
  395.  
  396.  
  397.  
  398. #define PUT_CODE_AND_SHORT(CODE,SH) \
  399.   PUT(MAKE_CODE(CODE,TOP(SH))); \
  400.   PUT(BOTTOM(SH)); 
  401.  
  402. #define READ_SYMBOL(leng,pack,to) \
  403.     do {char  *p=alloc_relblock(leng);\
  404.      FREAD(p,1,leng,fas_stream); \
  405.      string_register->st.st_fillp = \
  406.      string_register->st.st_dim = leng; \
  407.      string_register->st.st_self = p; \
  408.      to=(pack==Cnil ? make_symbol(string_register) : intern(string_register,pack)); }while(0)
  409.  
  410. #define  READ_STRING(leng,loc)    \
  411.      *loc = alloc_simple_string(leng); \
  412.      (*loc)->st.st_self=alloc_relblock(leng); \
  413.   FREAD((*loc)->st.st_self,1,leng,fas_stream);
  414.  
  415. /* if try_hash finds it we don't need to write the object
  416.    Otherwise we write the index type and the object
  417.  */
  418. #define NUMBER_ZERO_ITEMS (SHORT_MAX - (int) d_indexed_item0)
  419.  
  420.  
  421.  
  422. enum circ_ind
  423. do_hash(obj,dot)
  424.      object obj;
  425.      int dot;
  426. {    struct htent *e;
  427.      int i;
  428.      int result;
  429.      e=gethash(obj,dump_hash_table); 
  430.      if (e->hte_key==OBJNULL) 
  431. /* We won't index things unless they have  < -2 in the hash table */
  432.   {   if(type_of(obj)!=t_package) return NOT_INDEXED;
  433.       sethash(obj,dump_hash_table,make_fixnum(dump_index));
  434.       e=gethash(obj,dump_hash_table);     
  435.     PUT_OP(d_new_indexed_item);
  436.     DPRINTF("{dump_index=%d}",dump_index);
  437.     dump_index++;
  438.     return FIRST_INDEX;}
  439.     
  440.      i = fix(e->hte_value);
  441.      if (i == -1) return NOT_INDEXED; /* don't want to index this baby */
  442.      
  443.      if (dot) PUT_OP(dot);
  444.      if ( i < -1)
  445.        { e->hte_value = make_fixnum(dump_index);
  446.      PUT_OP(d_new_indexed_item);
  447.      DPRINTF("{dump_index=%d}",dump_index);
  448.      dump_index++;
  449.      return FIRST_INDEX;
  450.        }
  451.      if (i < (NUMBER_ZERO_ITEMS))
  452.        {PUT_OP(i+(int)d_indexed_item0); return LATER_INDEX;}
  453.      if (i < (2*SHORT_MAX - (int)d_indexed_item0))
  454.        {PUT_OP((int)d_indexed_item1);
  455.     PUTD("n=%d",i- NUMBER_ZERO_ITEMS);
  456.     return LATER_INDEX;
  457.       }
  458.      if (i < SHORT_MAX*SHORT_MAX)
  459.        {PUT_OP((int)d_indexed_item2);
  460.     PUT2(i);
  461.     return LATER_INDEX;
  462.       }
  463.      if (i < SHORT_MAX*SHORT_MAX*SHORT_MAX)
  464.        {PUT_OP((int)d_indexed_item3);
  465.      PUT3(i);
  466.      return LATER_INDEX;
  467.        }
  468.      else
  469.        FEerror("too large an index");
  470.      return LATER_INDEX;
  471.    }
  472.  
  473.  
  474. object
  475. write_fasd_top(obj,x)
  476.      object x,obj;
  477.  {struct fasd *fd = (struct fasd *) x->v.v_self;
  478.   if (fd->direction == Koutput)
  479.     SETUP_FASD_IN(fd);
  480.   else FEerror("bad value for open slot of fasd");
  481.  
  482.   write_fasd(obj);
  483.   /* we could really allocate a fixnum and then smash its field if this
  484.      is to costly */
  485.   (fd)->index = make_fixnum(dump_index);
  486.   return obj;
  487. }
  488.  
  489. /* It is assumed that anything passed to eval should be first
  490.    sharp patched, and that there will be no more patching afterwards.
  491.    The object returned might have arbitrary complexity.
  492. */   
  493.  
  494. #define MAYBE_PATCH(result) \
  495.   if (needs_patching)  result =fasd_patch_sharp(result,0)
  496.  
  497. object
  498. read_fasd_top(x)
  499.    object x;
  500. {  struct fasd *fd = (struct fasd *)  x->v.v_self;
  501.    int i;
  502.    VOL int e=0;
  503.    object result;
  504.  
  505.    
  506.    SETUP_FASD_IN(fd);
  507.  
  508.    frs_push(FRS_PROTECT, Cnil);
  509.    if (nlj_active) {
  510.      e = TRUE;
  511.      goto L;
  512.    }
  513.    needs_patching=0;
  514.    if (current_fasd.direction == Kinput)
  515.      {read_fasd1(GET_OP(),&result);
  516.       MAYBE_PATCH(result);
  517.       (fd)->index = make_fixnum(dump_index);
  518.       fd->direction=current_fasd.direction;
  519.  
  520.     }
  521.    else
  522.      if(current_fasd.direction== Cnil) result= current_fasd.eof;
  523.    else
  524.        FEerror("Stream not open for input");
  525.  L:
  526.  
  527.    frs_pop();
  528.    
  529.    if (e) {
  530.      nlj_active = FALSE;
  531.      unwind(nlj_fr, nlj_tag);
  532.      fd->direction=Cnil;
  533.      return Cnil;
  534.    }
  535.    else
  536.      return result;
  537.  }
  538.  
  539. object Seq;
  540. object siSPinit;
  541. void Lmake_hash_table();
  542.  
  543. object
  544. open_fasd(stream,direction,eof,tabl)
  545.      object stream,direction,eof,tabl;
  546. {  object str=Cnil;
  547.    object result;
  548.    if(direction==Kinput)
  549.      {str=coerce_stream(stream,0);
  550.       if (tabl==Cnil)
  551.     tabl=alloc_simple_vector(0,aet_object);
  552.       else
  553.     check_type(tabl,t_vector);}
  554.    if(direction==Koutput)
  555.      {str=coerce_stream(stream,1);
  556.       if(tabl==Cnil) tabl=funcall_cfun(Lmake_hash_table,2,Ktest,Seq);
  557.       else
  558.     check_type(tabl,t_hashtable);}
  559.    check_type(str,t_stream);
  560.    result=alloc_simple_vector(sizeof(struct fasd)/sizeof(int),aet_object);
  561.    array_allocself(result,1,Cnil);
  562.    {struct fasd *fd= (struct fasd *)result->v.v_self;
  563.     fd->table=tabl;
  564.     fd->stream=stream;
  565.     fd->direction=direction;
  566.     fd->eof=eof;
  567.     fd->index=small_fixnum(0);
  568.     fd->package=symbol_value(Vpackage);
  569.     fd->filepos = make_fixnum(file_position(stream));
  570.     
  571.     SETUP_FASD_IN(fd);
  572.     if (direction==Koutput){
  573.       PUT_OP((int)d_begin_dump);
  574.       PUTD("version=%d",FASD_VERSION);
  575.       PUT4(0);  /* reserve space for the size of index array needed */
  576.           /*  equivalent to:   write_fasd(current_fasd.package);
  577.           except we don't want to index this, so that we can open
  578.           with an empty array.
  579.        */
  580.       PUT_OP(d_package);
  581.       write_fasd(current_fasd.package->p.p_name);
  582.  
  583.     }
  584.     else            /* input */
  585.       { object tem;
  586.     read_fasd1(GET_OP(),&tem);
  587.     if(tem!=current_fasd.table) FEerror("not positioned at beginning of a dump");
  588.       }
  589.     fd->index=make_fixnum(dump_index);
  590.     fd->filepos=current_fasd.filepos;
  591.     fd->package=current_fasd.package;
  592.     return result;
  593.   }}
  594.  
  595. object
  596. close_fasd(ar)
  597.      object ar;
  598. {  struct fasd *fd= (struct fasd *)(ar->v.v_self);
  599.    check_type(ar,t_vector);
  600.    if (type_of(fd->table)==t_vector)
  601.      /* input uses a vector */
  602.      {if (fd->table->v.v_self)
  603.        gset(fd->table->v.v_self,0,fix(fd->index),aet_object);
  604.     }
  605.    else
  606.      if(fd->direction==Koutput)
  607.        {clrhash(fd->table);
  608.     SETUP_FASD_IN(fd);
  609.     PUT_OP(d_end_of_file);
  610.     {int i = file_position(fd->stream);
  611.      if(type_of(fd->filepos) == t_fixnum)
  612.       { file_position_set(fd->stream,fix(fd->filepos) +2);
  613.         /* record the length of array needed to read the indices */
  614.         PUT4(fix(fd->index));
  615.         /* move back to where we were */
  616.         file_position_set(fd->stream,i);
  617.       }}
  618.      
  619.       }
  620.    /*  else FEerror("bad fasd stream"); */
  621.    fd->direction=Cnil;
  622.    return ar;
  623.   
  624.  }
  625.  
  626.  
  627. #define HASHP(x) 1
  628. #define TRY_HASH \
  629.   if(do_hash(obj,0)==LATER_INDEX) return;
  630.  
  631. write_fasd(obj)
  632.      object obj;
  633. {  int j,leng;
  634.  
  635.    /* hook for writing other data in fasd file */
  636.  
  637.  
  638.    
  639.    /* check if we have already output the object in a hash table.
  640.       If so just record the index */
  641.    {
  642.      /* if dump_index is too large or the object has not been written before
  643.     we output it now */
  644.  
  645.      switch(type_of(obj)){
  646.  
  647.      case DP(t_cons:)
  648.        TRY_HASH;
  649.  
  650.        /* decide how long we think this list is */
  651.        
  652.        {object x=obj->c.c_cdr;
  653.     int l=0;
  654.     if (obj->c.c_car == siSsharp_comma)
  655.       { PUT_OP(d_eval);
  656.         write_fasd(x);
  657.         break;}
  658.     while(1)
  659.       { if(x==Cnil)
  660.           {PUT_OP(d_list1+l);
  661.            break;}
  662.         if(type_of(x)==t_cons)
  663.           {if ((int) d_list1 + ++l > (int) d_list4)
  664.            {PUT_OP(d_list);
  665.         break;}
  666.            else {x=x->c.c_cdr;
  667.              continue;}}
  668.         /* 1 to 4 done */
  669.         if(l==0)
  670.           {PUT_OP(d_cons);
  671.            write_fasd(obj->c.c_car);
  672.            write_fasd(obj->c.c_cdr);
  673.            return;}
  674.         else
  675.           {PUT_OP(d_list);
  676.            break;
  677.          }}}
  678.  
  679.      WRITE_LIST:
  680.  
  681.        write_fasd(obj->c.c_car);
  682.        obj=obj->c.c_cdr;
  683.        {int l=0;
  684.     while(1)
  685.       {if (type_of(obj)==t_cons)
  686.          { enum circ_ind is_indexed=LATER_INDEX;
  687.            if(HASHP(t_cons)){
  688.          is_indexed=do_hash(obj,d_dot);
  689.          if  (is_indexed == LATER_INDEX)
  690.          return;
  691.            if (is_indexed==FIRST_INDEX)
  692.          { PUT_OP(d_cons);
  693.            write_fasd(obj->c.c_car);
  694.            write_fasd(obj->c.c_cdr);
  695.           return;}}
  696.            write_fasd(obj->c.c_car);
  697.            l++;
  698.            obj=obj->c.c_cdr;}
  699.        else
  700.          if(obj==Cnil)
  701.            {if (l> ((int) d_list4- (int) d_list1))
  702.           {PUT_OP(d_delimiter);}
  703.         return;}
  704.        else
  705.          {PUT_OP(d_dot);
  706.           write_fasd(obj);
  707.           return;}}}
  708.  
  709.      case DP(t_symbol:)
  710.           
  711.        if (obj==Cnil)
  712.      {PUT_OP(d_nil); return;}
  713.         TRY_HASH;
  714.        leng=obj->s.s_fillp;
  715.        if (current_fasd.package!=obj->s.s_hpack)
  716.      {{
  717.        if (leng< SHORT_MAX)
  718.           {PUT_OP(d_short_symbol_and_package);
  719.            PUTD("leng=%d",leng);}
  720.        else
  721.          { j=leng;
  722.            PUT_OP(d_symbol_and_package);
  723.            PUT4(j);}}
  724.       
  725.       write_fasd(obj->s.s_hpack);}
  726.        else
  727.      { if (leng< SHORT_MAX)
  728.          { PUT_OP(d_short_symbol);
  729.            PUTD("leng=%d",leng);}
  730.      else
  731.        { j=leng;
  732.          PUT_OP(d_symbol);
  733.          PUT4(j);}
  734.        }
  735.        FWRITE(obj->s.s_self,1,leng,fas_stream);
  736.        break;
  737.      case DP(t_fixnum:)
  738.        leng=fix(obj);
  739.        if ((leng< (SHORT_MAX/2))
  740.        && (leng > -(SHORT_MAX/2)))
  741.      {PUT_OP(d_short_fixnum);
  742.         PUTD("leng=%d",leng);}
  743.        else
  744.      {PUT_OP(d_fixnum);
  745.       j=leng;
  746.       PUT4(j);}
  747.        break;
  748.      case DP(t_character:)
  749.        PUT_OP(d_standard_character);
  750.        PUTD("char=%c",char_code(obj));
  751.        break;
  752.      case DP(t_string:)
  753.        leng=(obj)->st.st_fillp;
  754.        if (leng< SHORT_MAX)
  755.      {PUT_OP(d_short_string);
  756.       PUTD("leng=%d",leng);}
  757.        else
  758.      {j=leng;
  759.       PUT_OP(d_string);
  760.       PUT4(j);}
  761.        FWRITE(obj->st.st_self,1,leng,fas_stream);
  762.        break;
  763.      case DP(t_bignum:)
  764.        PUT_OP(d_bignum);
  765.        {int l = obj->big.big_length;
  766.     long *u = obj->big.big_self;
  767.     PUT4(l);
  768.     while (-- l >=0)
  769.       {PUT4(*u) ; u++;}
  770.        break;}
  771.      case DP(t_package:)
  772.        TRY_HASH;
  773.        PUT_OP(d_package);
  774.        write_fasd(obj->p.p_name);
  775.        break;
  776.      case DP(t_structure:)
  777.  
  778.        TRY_HASH;
  779.        {int narg=S_DATA(obj->str.str_def)->length;
  780.     int i;
  781.     object name= S_DATA(obj->str.str_def)->name;
  782.     if(narg >= SHORT_MAX)
  783.       FEerror("Only dump structures whose length < ~a",1,make_fixnum(SHORT_MAX));
  784.     PUT_OP(d_structure);
  785.     PUTD("narg=%d",narg);
  786.     write_fasd(name);
  787.     for (i = 0;  i < narg;  i++)
  788.         write_fasd(structure_ref(obj,name,i));}
  789.  
  790.     break;
  791.  
  792.       case DP(t_array:)
  793.     TRY_HASH;
  794.     PUT_OP(d_array);
  795.     { int leng=obj->a.a_dim;
  796.       int i;
  797.       PUT4(leng);
  798.       PUTD("elttype=%d",obj->a.a_elttype);
  799.       PUTD("rank=%d",obj->a.a_rank);
  800.       {int i;
  801.        if (obj->a.a_rank > 1)
  802.          {
  803.            for (i=0; i<obj->a.a_rank ; i++)
  804.          PUT4(obj->a.a_dims[i]);}}
  805.       for(i=0; i< leng ; i++)
  806.         write_fasd(aref(obj,i));}
  807.       break;
  808.     
  809.       case DP(t_vector:)
  810.     TRY_HASH;
  811.     PUT_OP(d_vector);
  812.     { int leng=obj->v.v_fillp;
  813.       PUT4 (leng);
  814.       PUTD("eltype=%d",obj->v.v_elttype);
  815.       {int i;
  816.        for(i=0; i< leng ; i++)
  817.          {write_fasd(aref(obj,i));}}}
  818.     break;
  819.       
  820.     
  821.      default:
  822.        PUT_OP(d_general_type);
  823.        prin1(obj,current_fasd.stream);
  824.        PUTD("close general:%c",')');
  825.       
  826.      }}
  827.  }
  828.  
  829.  
  830. object
  831. fasd_patch_sharp_cons(x,depth)
  832.      int depth;
  833. object x;
  834. {
  835.     for (;;) {
  836.         x->c.c_car = fasd_patch_sharp(x->c.c_car,depth+1);
  837.         if (type_of(x->c.c_cdr) == t_cons)
  838.             x = x->c.c_cdr;
  839.         else {
  840.             x->c.c_cdr = fasd_patch_sharp(x->c.c_cdr,depth+1);
  841.             break;
  842.         }
  843.     }
  844. }
  845.  
  846. object
  847. fasd_patch_sharp(x,depth)
  848. object x;
  849. {   object p;
  850.     cs_check(x);
  851.     if (++depth > 1000)
  852.       { object *p = current_fasd.table->v.v_self;
  853.         while(*p)
  854.           { if (x== *p++ && type_of(x)!=t_spice) return x;}}
  855.     /* eval'd forms are already patched, and they might contain
  856.       circular structure */
  857.     { object p = current_fasd.evald_items;
  858.       while (p != Cnil)
  859.         { if (p->c.c_car == x) return x;
  860.           p = p->c.c_cdr;}}
  861.  
  862.     switch (type_of(x)) {
  863.     case DP(t_spice:)
  864.     {  if (x->spc.spc_dummy >=  current_fasd.table->v.v_dim)
  865.          FEerror("bad spice ref");
  866.        return  current_fasd.table->v.v_self[x->spc.spc_dummy ];
  867.  
  868.     }
  869.     case DP(t_cons:)
  870.     /*
  871.         x->c.c_car = fasd_patch_sharp(x->c.c_car,depth);
  872.         x->c.c_cdr = fasd_patch_sharp(x->c.c_cdr,depth);
  873.     */
  874.         fasd_patch_sharp_cons(x,depth);
  875.         break;
  876.  
  877.     case DP(t_vector:)
  878.     {
  879.         int i;
  880.  
  881.         if ((enum aelttype)x->v.v_elttype != aet_object)
  882.           break;
  883.  
  884.         for (i = 0;  i < x->v.v_fillp;  i++)
  885.             x->v.v_self[i] = fasd_patch_sharp(x->v.v_self[i],depth);
  886.         break;
  887.     }
  888.     case DP(t_array:)
  889.     {
  890.         int i, j;
  891.         
  892.         if ((enum aelttype)x->a.a_elttype != aet_object)
  893.           break;
  894.  
  895.         for (i = 0, j = 1;  i < x->a.a_rank;  i++)
  896.             j *= x->a.a_dims[i];
  897.         for (i = 0;  i < j;  i++)
  898.             x->a.a_self[i] = fasd_patch_sharp(x->a.a_self[i],depth);
  899.         break;
  900.     }
  901.     case DP(t_structure:)
  902.     {object def = x->str.str_def;
  903.      int i;
  904.      i=S_DATA(def)->length;
  905.      while (i--> 0)
  906.        structure_set(x,def,i,fasd_patch_sharp(structure_ref(x,def,i),depth));
  907.      break;
  908.        }
  909.     
  910.     }
  911.     return(x);
  912. }
  913.  
  914. static object sharing_table;
  915. enum circ_ind
  916. is_it_there(x)
  917.      object x;
  918. { struct htent *e;
  919.   object table=sharing_table;
  920.   switch(type_of(x)){
  921.   case t_cons:
  922.   case t_symbol:
  923.   case t_structure:
  924.   case t_array:
  925.   case t_vector:
  926.   case t_package:
  927.   e= gethash(x,table);
  928.     if (e->hte_key ==OBJNULL)
  929.       {sethash(x,table,make_fixnum(-1));
  930.        return FIRST_INDEX;
  931.      }
  932.     else
  933.       {int n=fix(e->hte_value);
  934.        if (n <0)
  935.      e->hte_value=make_fixnum(n-1);
  936.        return LATER_INDEX;}
  937.   break;
  938.  default:
  939.   return NOT_INDEXED;}}
  940.  
  941. object
  942. find_sharing_top(x,table)
  943. object x,table;
  944. {sharing_table=table;
  945.  find_sharing(x);
  946.  return Ct;}
  947.  
  948.  
  949. find_sharing(x)
  950. object x;
  951. {
  952.   cs_check(x);
  953.  BEGIN:
  954.   if(is_it_there(x)!=FIRST_INDEX) return;  
  955.  
  956.     switch (type_of(x)) {
  957.  
  958.     case DP(t_cons:)
  959.  
  960.       find_sharing(x->c.c_car);
  961.       x=x->c.c_cdr;
  962.       goto BEGIN; 
  963.       
  964.       break;
  965.  
  966.     case DP(t_vector:)
  967.     {
  968.         int i;
  969.  
  970.         if ((enum aelttype)x->v.v_elttype != aet_object)
  971.           break;
  972.  
  973.         for (i = 0;  i < x->v.v_fillp;  i++)
  974.           find_sharing(x->v.v_self[i]);
  975.         break;
  976.     }
  977.     case DP(t_array:)
  978.     {
  979.         int i, j;
  980.         
  981.         if ((enum aelttype)x->a.a_elttype != aet_object)
  982.           break;
  983.  
  984.         for (i = 0, j = 1;  i < x->a.a_rank;  i++)
  985.             j *= x->a.a_dims[i];
  986.         for (i = 0;  i < j;  i++)
  987.             find_sharing(x->a.a_self[i]);
  988.         break;
  989.     }
  990.     case DP(t_structure:)
  991.       {object def = x->str.str_def;
  992.      int i;
  993.      i=S_DATA(def)->length;
  994.      while (i--> 0)
  995.             find_sharing(structure_ref(x,def,i));
  996.      break;
  997.        }
  998.  
  999.     
  1000.     }
  1001.     return;
  1002. }
  1003.  
  1004.  
  1005. object           
  1006. read_fasd(i)
  1007.      int i;
  1008.   {object tem;
  1009.    read_fasd1(i,&tem);
  1010.    return tem;}
  1011.  
  1012.  
  1013.      /* I am not sure if saving vs_top,vs_base is necessary */
  1014. object 
  1015. lisp_eval(x)
  1016. object x;
  1017. {  object *b,*t;
  1018.    SAVE_CURRENT_FASD;
  1019.    b=vs_base;
  1020.    t=vs_top;
  1021.    vs_base=vs_top;
  1022.    vs_push(x);
  1023.    Leval(); 
  1024.    x=vs_base[0];
  1025.    vs_base=b;
  1026.    vs_top=t;
  1027.    RESTORE_FASD;
  1028.    return x;
  1029.  }
  1030.  
  1031.     
  1032.  
  1033. #define CHECK_CH(i)           do{if ((i)==EOF & feof(fas_stream)) bad_eof();}while (0)
  1034. /* grow vector AR of general type */
  1035. grow_vector(ar)
  1036.      object ar;
  1037. {   int len=ar->v.v_dim;
  1038.     int nl=(int) (1.5*len);
  1039.     char *p= (char *)AR_ALLOC(alloc_contblock,nl,object);
  1040.     bcopy(ar->v.v_self,p,sizeof(object)* len);
  1041.     ar->v.v_self= (object *)p;
  1042.     ar->v.v_dim=       ar->v.v_fillp=nl;
  1043.     while(--nl >=len)
  1044.       ar->v.v_self[nl]=Cnil;
  1045.   }
  1046.  
  1047. bad_eof()
  1048. {  FEerror("Unexpected end of file",0);}
  1049.  
  1050.  
  1051.  
  1052. /* read one starting with byte i into location loc */
  1053. void
  1054. read_fasd1(i,loc)
  1055.      object *loc;
  1056.      int i;
  1057. {  object tem;
  1058.    int leng;
  1059.  BEGIN:
  1060.    CHECK_CH(i);
  1061.    switch(D_TYPE_OF(i))
  1062.      {case DP(d_nil:)
  1063.     *loc=Cnil;return;
  1064.       case DP(d_cons:)
  1065.     read_fasd1(GET_OP(),&tem);
  1066.     *loc=make_cons(tem,Cnil);
  1067.     loc= &((*loc)->c.c_cdr);
  1068.     i=GET_OP();
  1069.     goto BEGIN;
  1070.       case DP(d_list1:) i=1;goto READ_LIST;
  1071.       case DP(d_list2:) i=2;goto READ_LIST;
  1072.       case DP(d_list3:) i=3;goto READ_LIST;
  1073.       case DP(d_list4:) i=4;goto READ_LIST;
  1074.       case DP(d_list:)  i=(1<<30) ; goto READ_LIST;
  1075.  
  1076.       READ_LIST:
  1077.     while(1)
  1078.       {int j;
  1079.        if (--i < 0) {*loc=Cnil; return;}
  1080.        DP(reading_list:) ; 
  1081.        j=GET_OP();
  1082.        CHECK_CH(j);
  1083.        if (j==d_delimiter)
  1084.          {*loc=Cnil;
  1085.           DPRINTF("{Read end of list(%d)}",i);
  1086.           return;}
  1087.        else
  1088.          if(j==d_dot)
  1089.            { DPRINTF("{Read end of dotted list(%d)}",i);
  1090.          read_fasd1(GET_OP(),loc);
  1091.         
  1092.          return;}
  1093.          else
  1094.            {object tem;
  1095.         DPRINTF("{Read next item in list(%d)}",i);
  1096.         read_fasd1(j,&tem);
  1097.         DPRINTF("{Item=",(debug >= 2 ? pp(tem) : 0));
  1098.         DPRINTF("}",0);
  1099.         *loc=make_cons(tem,Cnil);
  1100.         loc= &((*loc)->c.c_cdr);}}
  1101.  
  1102.       case DP(d_delimiter:)
  1103.       case DP(d_dot:)
  1104.     FEerror("Illegal op at top level");
  1105.     break;
  1106.       case DP(d_eval_skip:)
  1107.     read_fasd1(GET_OP(),loc);
  1108.     MAYBE_PATCH(*loc);
  1109.     lisp_eval(*loc);
  1110.     read_fasd1(GET_OP(),loc);
  1111.     break;
  1112.  
  1113.       case d_reserve1:
  1114.       case d_reserve2:
  1115.       case d_reserve3:
  1116.       case d_reserve4:
  1117.        
  1118.     FEerror("Op reserved for future use");
  1119.     break;
  1120.  
  1121.       case DP(d_reset_index:)
  1122.     dump_index=0;
  1123.     break;
  1124.        
  1125.       case DP(d_short_symbol:)
  1126.     leng=GETD("leng=%d");
  1127.     leng = LENGTH(i,leng);
  1128.     READ_SYMBOL(leng,current_fasd.package,tem);
  1129.     *loc=tem;
  1130.     return ;
  1131.       case DP(d_short_symbol_and_package:)
  1132.     {object pack;
  1133.      leng=GETD("leng=%d");
  1134.      leng = LENGTH(i,leng);
  1135.      read_fasd1(GET_OP(),&pack);
  1136.      READ_SYMBOL(leng,pack,tem);
  1137.      *loc=tem;
  1138.      return;}
  1139.       case DP(d_short_string:)
  1140.     leng=GETD("leng=%d");
  1141.     leng = LENGTH(i,leng);
  1142.     READ_STRING(leng,loc);
  1143.     return;
  1144.       case DP(d_string:)
  1145.     {int j;
  1146.      GET4(j);
  1147.      READ_STRING(j,loc);
  1148.      return;}
  1149.       
  1150.       case DP(d_indexed_item3:)
  1151.     GET3(i);goto INDEXED;
  1152.       case DP(d_indexed_item2:)
  1153.     GET2(i);goto INDEXED;
  1154.       case DP(d_indexed_item1:)
  1155.     i=GET()+ NUMBER_ZERO_ITEMS ; goto INDEXED;
  1156.       default:
  1157.       case DP(d_indexed_item0:)
  1158.     i = i - (int) d_indexed_item0; goto INDEXED;
  1159.  
  1160.       INDEXED:    
  1161.       
  1162.     *loc= current_fasd.table->v.v_self[i];
  1163.     /* if object not yet built make pointer to it */
  1164.     if(*loc==0)
  1165.       {*loc=current_fasd.table->v.v_self[i]= alloc_object(t_spice);
  1166.        (*loc)->spc.spc_dummy= i;
  1167.        needs_patching=1;}
  1168.     return;
  1169.  
  1170.     /* the item`s' case does not return a value but is simply
  1171.        a facility to allow convenient dumping of a list of registers
  1172.        at the beginning, follwed by a delimiter.   read continues on. */
  1173.  
  1174.       case DP(d_new_indexed_items:)
  1175.       case DP(d_new_indexed_item:)
  1176.  
  1177.     {object tem;
  1178.      int cindex,k;
  1179.      k=GET_OP();
  1180.        MORE:
  1181.      cindex =dump_index;
  1182.      DPRINTF("{dump_index=%d}",dump_index);
  1183.      if (dump_index >= current_fasd.table->v.v_dim)
  1184.        grow_vector(current_fasd.table);
  1185.      /* grow the array */
  1186.      current_fasd.table->v.v_self[dump_index++] = 0;
  1187.      read_fasd1(k,loc);
  1188.      current_fasd.table->v.v_self[cindex] = *loc;
  1189.        
  1190.      if (i==d_new_indexed_items)
  1191.        {int k=GET_OP();
  1192.         if (k==d_delimiter)
  1193.           { DPRINTF("{Reading last of new indexed items}",0);
  1194.         read_fasd1(GET_OP(),loc);
  1195.         return;}
  1196.         else { 
  1197.           goto MORE;
  1198.         }}
  1199.      return;
  1200.        }
  1201.       case DP(d_short_fixnum:)
  1202.     {int leng=GETD("n=%d");
  1203.      if (leng & (1 << (SIZE_SHORT -1)))
  1204.        leng= leng - (1 << (SIZE_SHORT));
  1205.      *loc=make_fixnum(leng);
  1206.      return;}
  1207.     
  1208.       case DP(d_fixnum:)
  1209.     {int j;
  1210.      GET4(j);
  1211.      *loc=make_fixnum(j);       
  1212.      return;}
  1213.       case DP( d_bignum:)
  1214.     {int j;
  1215.      object tem;
  1216.      long *u;
  1217.      GET4(j);
  1218.      tem = alloc_object(t_bignum);
  1219.      tem->big.big_length = j;
  1220.      tem-> big.big_self = 0;
  1221.      u = tem-> big.big_self = (long *) alloc_relblock(j*sizeof(long));
  1222.      while ( --j >=0)
  1223.        { GET4(*u);
  1224.          u++;}
  1225.      *loc=tem; return;}
  1226.       case DP(d_objnull:)
  1227.  
  1228.     *loc=0; return;
  1229.  
  1230.       case DP(d_structure:)
  1231.     { int narg,i,tem;
  1232.           object name;
  1233.           narg=GETD("narg=%d");
  1234.           read_fasd1(GET_OP(),& name);
  1235.           { object *base=vs_top;
  1236.         object *p = base;
  1237.         vs_base=base;
  1238.         vs_top = base + 1 + narg;
  1239.         *p++ = name;
  1240.         for (i=0; i < narg ; i++)
  1241.           read_fasd1(GET_OP(),p++);
  1242.         vs_base=base;
  1243.         vs_top = p;
  1244.         siLmake_structure();
  1245.         *loc = vs_base[0];
  1246.         vs_top=vs_base=base;
  1247.         return;
  1248.       }}
  1249.  
  1250.       case DP(d_symbol:)
  1251.     {int i; object tem;
  1252.      GET4(i);
  1253.      READ_SYMBOL(i,current_fasd.package,tem);
  1254.      *loc=tem;
  1255.      return ;}
  1256.       case DP(d_symbol_and_package:)
  1257.     {int i; object pack;
  1258.      GET4(i);  
  1259.      read_fasd1(GET_OP(),&pack);
  1260.      READ_SYMBOL(i,pack,*loc);
  1261.      return;}
  1262.       case DP(d_package:)
  1263.     {object pack,tem;
  1264.      read_fasd1(GET_OP(),&tem);
  1265.      pack=find_package(tem);
  1266.      if (pack==Cnil) FEerror("The package named ~a, does not exist",1,tem);
  1267.      *loc=pack;
  1268.      return ;}
  1269.       case DP(d_standard_character:)
  1270.     *loc=(code_char(GETD("char=%c")));
  1271.     return;
  1272.       case DP(d_vector:)
  1273.     {int leng,j;
  1274.      object y;
  1275.      object x=alloc_object(t_vector);
  1276.      GET4(leng);
  1277.      x->v.v_elttype = GETD("v_elttype=%d");
  1278.      x->v.v_dim=x->v.v_fillp=leng;
  1279.      x->v.v_self=0;
  1280.      x->v.v_displaced=Cnil;
  1281.      x->v.v_hasfillp=x->v.v_adjustable=0;
  1282.      array_allocself(x,0,Cnil);
  1283.      for (j=0; j< leng ; j++)
  1284.        { DPRINTF("{vector_elt=%d}",j);
  1285.          read_fasd1(GET_OP(),&y);
  1286.          aset(x,j,y);}
  1287.      *loc=x;
  1288.      DPRINTF("{End of length %d vector}",leng);
  1289.      return;}
  1290.  
  1291.  
  1292.       case DP(d_array:)
  1293.     {int leng,i;
  1294.      object y;
  1295.      object x=alloc_object(t_array);
  1296.      GET4(leng);
  1297.      x->a.a_elttype = GETD("a_elttype=%d");
  1298.      x->a.a_dim=leng;
  1299.      x->a.a_rank= GETD("a_rank=%d");
  1300.      x->a.a_self=0;
  1301.      x->a.a_displaced=Cnil;
  1302.      x->a.a_adjustable=0;
  1303.      if (x->a.a_rank > 0)
  1304.        { x->a.a_dims = (int *)alloc_relblock(sizeof(int)*(x->a.a_rank)); }
  1305.      for (i=0; i< x->a.a_rank ; i++)
  1306.        GET4(x->a.a_dims[i]);
  1307.      array_allocself(x,0,Cnil);
  1308.      for (i=0; i< leng ; i++)
  1309.        { read_fasd1(GET_OP(),&y);
  1310.          aset(x,i,y);}
  1311.      *loc=x;
  1312.      return;}
  1313.     
  1314.       case DP(d_end_of_file:)
  1315.     current_fasd.direction =Cnil;
  1316.     *loc=current_fasd.eof;
  1317.     return;
  1318.  
  1319.       case DP(d_begin_dump:)
  1320.     {int vers=GETD("version=%d");
  1321.      object tem;
  1322.      if(vers!=FASD_VERSION)
  1323.        FEerror("This file was dumped with FASD version ~a not ~a.",
  1324.            2,make_fixnum(vers),make_fixnum(FASD_VERSION));}
  1325.     {int leng;
  1326.      GET4(leng);
  1327.      current_fasd.table_length=make_fixnum(leng);}
  1328.     read_fasd1(GET_OP(),&tem);
  1329.         if (type_of(tem)==t_package || tem==Cnil)
  1330.       {current_fasd.package = tem;
  1331.        *loc=current_fasd.table;}
  1332.     else FEerror("expected package");
  1333.     return;
  1334.     
  1335.       case DP(d_general_type:)
  1336.     *loc=read_object_non_recursive(current_fasd.stream);
  1337.     if(GETD("close general:%c")!=')') FEerror("general type not followed by ')'");
  1338.     return;
  1339.       
  1340.  
  1341.     /* Special type, the forms have been sharp patched separately
  1342.        It is also arranged that it does not 
  1343.        */
  1344.      
  1345.       case DP(d_enter_vector:)
  1346.     {object *base=vs_top,x,y;
  1347.      extern object siSPmemory;
  1348.      int print_only=0;
  1349.      int n = 0;
  1350.      object vv = siSPmemory->s.s_dbind,tem;
  1351.      if (vv == Cnil) print_only = 1;
  1352.      else
  1353.        if (type_of(vv)!=t_cfdata) FEerror("bad VectorToEnter");
  1354.      while ((i=GET_OP()) !=d_delimiter)
  1355.        {int eval=(i==d_eval_skip);
  1356.         if (print_only)
  1357.           { if (eval) princ_str("#!",Ct);
  1358.         else if (i== d_eval)
  1359.           princ_str("#.",Ct);}
  1360.         if(eval) i=GET_OP();
  1361.         read_fasd1(i, &tem);
  1362.         MAYBE_PATCH(tem);
  1363.         /* the eval entries don't enter it */
  1364.  
  1365.         if (print_only) {princ(tem,Ct);
  1366.                  princ_str(";",Ct);
  1367.                  princ(make_fixnum(n));
  1368.                  princ_str("\n",Ct);}
  1369.         else
  1370.           {
  1371.           if(eval)
  1372.         lisp_eval(tem);
  1373.           else
  1374.         {if (n >= vv->cfd.cfd_fillp) FEerror("cfd too small");
  1375.          vv->cfd.cfd_self[n++]=tem;}}}
  1376.      if (print_only==0) vv->cfd.cfd_fillp = n;
  1377.      *loc=vv;
  1378.      return;
  1379.        }
  1380.  
  1381.       case DP(d_eval:)
  1382.     {object tem;
  1383.      read_fasd1(GET_OP(),&tem);
  1384.      MAYBE_PATCH(tem);
  1385.      *loc = lisp_eval(tem);
  1386.      current_fasd.evald_items = make_cons(*loc,current_fasd.evald_items);
  1387.      return;
  1388.        }
  1389.     
  1390.       }}
  1391.        
  1392.  
  1393. clrhash(table)
  1394. object table;
  1395.   {int i;
  1396.    if (table->ht.ht_nent > 0 )
  1397.      for(i = 0; i < table->ht.ht_size; i++) {
  1398.        table->ht.ht_self[i].hte_key = OBJNULL;
  1399.        table->ht.ht_self[i].hte_value = OBJNULL;}
  1400.    table->ht.ht_nent =0;}
  1401.  
  1402. object read_fasl_vector1();
  1403. object
  1404. read_fasl_vector(in)
  1405. object in;
  1406. {char ch;
  1407.  object orig = in;
  1408.  object d;
  1409.  int tem;
  1410.  if (((tem=getc(in->sm.sm_fp)) == EOF) && feof(in->sm.sm_fp))
  1411.    { d = coerce_to_pathname(in);
  1412.      d = make_pathname(d->pn.pn_host,
  1413.                d->pn.pn_device,
  1414.                d->pn.pn_directory,
  1415.                d->pn.pn_name,
  1416.                make_simple_string("data"),
  1417.                d->pn.pn_version);
  1418.      d = coerce_to_namestring(d);
  1419.      in = open_stream(d,smm_input,Cnil,Cnil);
  1420.      if (in == Cnil)
  1421.        FEerror("Can't open file ~s",1,d);
  1422.    }
  1423.  else if (tem != EOF)
  1424.    { ungetc(tem,in->sm.sm_fp);}
  1425.   while (1)
  1426.    { ch=readc_stream(in);
  1427.      if (ch=='#')
  1428.        {unreadc_stream(ch,in);
  1429.     return read_fasl_vector1(in);}
  1430.      if (ch== d_begin_dump){
  1431.        unreadc_stream(ch,in);
  1432.        break;}}
  1433.  {object ar=open_fasd(in,Kinput,0,Cnil);
  1434.   int n=fix(current_fasd.table_length);
  1435.   object result,tem,last;
  1436. #ifdef HAVE_ALLOCA
  1437.   current_fasd.table->v.v_self
  1438.     = (object *)alloca(n*sizeof(object));
  1439. #else
  1440.   current_fasd.table->v.v_self
  1441.     = (object *)alloc_relblock(n*sizeof(object));
  1442. #endif
  1443.   current_fasd.table->v.v_dim=n;
  1444.   current_fasd.table->v.v_fillp=n;
  1445.   gset( current_fasd.table->v.v_self,0,n,aet_object);
  1446.   result=read_fasd_top(ar);
  1447.   if (type_of(result) !=t_vector) goto ERROR;
  1448.   last=result->v.v_self[result->v.v_fillp-1];
  1449.   if(type_of(last)!=t_cons || last->c.c_car !=siSPinit)
  1450.     goto ERROR;
  1451.   current_fasd.table->v.v_self = 0;
  1452.   close_fasd(ar);
  1453.   if (orig != in)
  1454.     close_stream(in);
  1455.   return result;
  1456.  ERROR: FEerror("Bad fasd stream ~a",1,in);
  1457.   return Cnil;
  1458. }}
  1459.     
  1460. init_fasdump()
  1461. {
  1462.   make_si_sfun("READ-FASD-TOP",read_fasd_top,1);
  1463.   make_si_sfun("WRITE-FASD-TOP",write_fasd_top,2);
  1464.   make_si_sfun("OPEN-FASD",open_fasd,4);  
  1465.   make_si_sfun("CLOSE-FASD",close_fasd,1);
  1466. /*  make_si_sfun("FASD-I-DATA",fasd_i_macro,1); */
  1467.   make_si_sfun("FIND-SHARING-TOP",find_sharing_top,2);
  1468. }
  1469.