This is fasdump.c in view mode; [Download] [Up]
/* Copyright William F. Schelter All Rights Reserved.
Utility for writing out lisp objects and reading them in:
Basically it attempts to write out only those things which could
be written out using princ and reread. It just uses less space
and is faster.
Primitives for dealing with a `fasd stream'.
Such a stream is really an array containing some state and a lisp file stream.
Note that having *print-circle* == nil wil make this faster. gensyms will
still be dumped correctly in that case.
open_fasd
write_fasd_top
read_fasd_top
close_fasd
*/
#ifndef FAT_STRING
#include "include.h"
#endif
object coerce_stream();
object fasd_patch_sharp();
object *sharp_ar;
int sharp_ind;
object siVPinit;
static int patch_indexed;
struct fasd {
object stream; /* lisp object of type stream */
object table; /* hash table used in dumping or vector on input*/
object eof; /* lisp object to be returned on coming to eof mark */
object direction; /* holds Cnil or Kinput or Koutput */
object package; /* the package symbols are in by default */
object index; /* integer. The current_dump index on write */
object filepos; /* nil or the position of the start */
object table_length; /* On read it is set to the size dump array needed
or 0
*/
object macro; /* Nil or a function of one arg (stream) returning the next
object from the stream. It will be called
from the reader, and may do read an arbitrary number of
args and possibly dispatch on the first one */
};
struct fasd current_fasd;
enum circ_ind {
LATER_INDEX,
NOT_INDEXED,
FIRST_INDEX,
};
enum dump_type {
d_nil, /* dnil: nil */
d_eval_skip, /* deval o1: evaluate o1 after reading it */
d_delimiter, /* occurs after d_list,d_general and d_new_indexed_items */
d_enter_vector, /* d_enter_vector o1 o2 .. on d_delimiter , make a cf_data with
this length. Used internally by akcl. Just make
an array in other lisps */
d_cons, /* d_cons o1 o2: (o1 . o2) */
d_dot,
d_list, /* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on
for (o1 o2 . on)
or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on)
*/
d_list1, /* nil terminated length 1 d_list1,o1 */
d_list2, /* nil terminated length 2 */
d_list3,
d_list4,
d_eval,
d_short_symbol,
d_short_string,
d_short_fixnum,
d_short_symbol_and_package,
d_bignum,
d_fixnum,
d_string,
d_objnull,
d_structure,
d_package,
d_symbol,
d_symbol_and_package,
d_end_of_file,
d_standard_character,
d_vector,
d_array,
d_begin_dump,
d_general_type,
d_sharp_equals, /* define a sharp */
d_sharp_value,
d_sharp_value2,
d_new_indexed_item,
d_new_indexed_items,
d_reset_index,
d_macro,
d_reserve1,
d_reserve2,
d_reserve3,
d_reserve4,
d_indexed_item3, /* d_indexed_item3 followed by 3bytes to give index */
d_indexed_item2, /* d_indexed_item2 followed by 2bytes to give index */
d_indexed_item1,
d_indexed_item0 /* This must occur last ! */
};
/* set whole structures! */
#define SETUP_FASD_IN(fd) do{ \
fas_stream= (fd)->stream->sm.sm_fp; \
dump_index = fix((fd)->index) ; \
current_fasd= * (fd);}while(0)
#define SAVE_CURRENT_FASD \
struct fasd old_fd; \
int old_dump_index = dump_index; \
FILE *old_fas_stream = fas_stream; \
old_fd = current_fasd;
#define RESTORE_FASD \
current_fasd =old_fd ; \
dump_index= old_dump_index ; \
fas_stream = old_fas_stream
#define FASD_SHARP_LIMIT 250 /* less than short_max */
#define SETUP_FASD_OUT(fasd) SETUP_FASD_IN(fasd)
#define dump_hash_table (current_fasd.table)
#define SIZE_D_CODE 8
#define SIZE_BYTE 8
#define SIZE_SHORT ((2*SIZE_BYTE) - SIZE_D_CODE)
/* this is not! the maximum short !! It is shorter */
#define SHORT_MAX ((1<< SIZE_SHORT) -1)
/* given SHORT extract top code (say 4 bits) and bottom byte */
#define TOP(i) (i >> SIZE_BYTE)
#define BOTTOM(i) (i & ~(~0 << SIZE_BYTE))
#define FASD_VERSION 2
FILE *fas_stream;
int dump_index;
struct htent *gethash();
void read_fasd1();
object extended_read();
/* #define DEBUG */
#ifdef DEBUG
#define PUT(x) putc1((char)x,fas_stream)
#define GET() getc1()
#define FWRITE fwrite1
#define FREAD fread1
char *dump_type_names[]={ "d_nil",
"d_eval_skip",
"d_delimiter",
"d_enter_vector",
"d_cons",
"d_dot",
"d_list",
"d_list1",
"d_list2",
"d_list3",
"d_list4",
"d_eval",
"d_short_symbol",
"d_short_string",
"d_short_fixnum",
"d_short_symbol_and_package",
"d_bignum",
"d_fixnum",
"d_string",
"d_objnull",
"d_structure",
"d_package",
"d_symbol",
"d_symbol_and_package",
"d_end_of_file",
"d_standard_character",
"d_vector",
"d_array",
"d_begin_dump",
"d_general_type",
"d_sharp_equals",
"d_sharp_value",
"d_sharp_value2",
"d_new_indexed_item",
"d_new_indexed_items",
"d_reset_index",
"d_macro",
"d_reserve1",
"d_reserve2",
"d_reserve3",
"d_reserve4",
"d_indexed_item3",
"d_indexed_item2",
"d_indexed_item1",
"d_indexed_item0"};
int debug;
print_op(i)
{if (debug)
{if (i < d_indexed_item0 & i >= 0)
{printf("\n<%s>",dump_type_names[i]);}
else {printf("\n<indexed_item0:%d>",i -d_indexed_item0);}}
return i;
}
#define PUTD(str,i) putd(str,i)
putd(str,i)
char *str;
int i;
{if (debug)
{printf("{");
printf(str,i);
printf("}");}
putc(i,fas_stream);}
putc1(x)
int x;
{ if (debug) printf("(%x,%d,%c)",x,x,x);
putc(x,fas_stream);
fflush(stdout);
}
getc1()
{ int x;
x= getc(fas_stream);
if (debug) printf("(%x,%d,%c)",x,x,x);
fflush(stdout);
return x;
}
fread1(p,n1,n2,st)
FILE* st;
char *p;
int n1;
int n2;
{int i,j;
j=fread(p,n1,n2,st);
if(debug)
{printf("[");
n1=n1*n2;
for(i=0;i<n1; i++)
putc(p[i],stdout);
printf("]");
fflush(stdout);}
return j;
}
fwrite1(p,n1,n2,st)
FILE* st;
char *p;
int n1;
int n2;
{int i,j;
j=fwrite(p,n1,n2,st);
if(debug)
{printf("[");
n1=n1*n2;
for(i=0;i<n1; i++)
putc(p[i],stdout);
printf("]");}
return j;
}
int char_read;
#define GET_OP() (print_op(getc(fas_stream)))
#define PUT_OP(x) fputc(print_op(x),fas_stream)
#define DP(sw) sw /* if (debug) {printf("\ncase sw");} */
#define GETD(str) getd(str)
getd(str)
char *str;
{ int i = getc(fas_stream);
if(debug){
printf("{");
printf(str,i);
printf("}");}
return i;}
#define DPRINTF(a,b) do{if(debug) printf(a,b);} while(0)
#else
#define PUT(x) putc((char)x,fas_stream)
#define GET() getc(fas_stream)
#define GET_OP GET
#define PUT_OP PUT
#define FWRITE fwrite
#define FREAD fread
#define DP(sw) sw
#define PUTD(a,b) PUT(b)
#define GETD(a) GET()
#define DPRINTF(a,b)
#endif
#define D_TYPE_OF(byt) \
((enum dump_type )((unsigned int) byt & ~(~0 << SIZE_D_CODE)))
/* this field may be the top of a short for length, or part of an extended
code */
#define E_TYPE_OF(byt) ((unsigned int) byt >> (SIZE_D_CODE))
/* takes two bytes and reconstructs the SIZE_SHORT int from them after
dropping the code */
/* takes two bytes i and j and returns the SHORT associated */
#define LENGTH(i,j) MAKE_SHORT(E_TYPE_OF(i),(j))
#define MAKE_SHORT(top,bot) (((top)<< SIZE_BYTE) + (bot))
#define READ_BYTE1() getc(fas_stream)
#define GET4(varx ) \
do{int var=READ_BYTE1(); \
var |= (READ_BYTE1() << SIZE_BYTE); \
var |= (READ_BYTE1() << (2*SIZE_BYTE)); \
var |= (READ_BYTE1() << (3*SIZE_BYTE)); \
DPRINTF("{4byte:varx= %d}", var); \
varx=var;} while (0)
#define GET2(varx ) \
do{int var=READ_BYTE1(); \
var |= (READ_BYTE1() << SIZE_BYTE); \
DPRINTF("{2byte:varx= %d}", var); \
varx=var;} while (0)
#define GET3(varx ) \
do{int var=READ_BYTE1(); \
var |= (READ_BYTE1() << SIZE_BYTE); \
var |= (READ_BYTE1() << (2*SIZE_BYTE)); \
DPRINTF("{3byte:varx= %d}", var); \
varx=var;} while (0)
#define MASK ~(~0 << 8)
#define WRITE_BYTEI(x,i) putc((((x) >> (i*SIZE_BYTE)) & MASK),fas_stream)
#define PUT4(varx ) \
do{int var= varx ; \
DPRINTF("{4byte:varx= %d}", var); \
WRITE_BYTEI(var,0); \
WRITE_BYTEI(var,1); \
WRITE_BYTEI(var,2); \
WRITE_BYTEI(var,3);} while(0)
#define PUT2(var ) \
do{int v=var; \
DPRINTF("{2byte:var= %d}", v); \
WRITE_BYTEI(v,0); \
WRITE_BYTEI(v,1); \
} while(0)
#define PUT3(var ) \
do{int v=var; \
DPRINTF("{3byte:var= %d}", v); \
WRITE_BYTEI(v,0); \
WRITE_BYTEI(v,1); \
WRITE_BYTEI(v,2); \
} while(0)
/* constructs the first byte containing ecode and top
top either stands for something in extended codes, or for something
the top part of a SIZE_SHORT int
*/
#define MAKE_CODE(CODE,Top) \
((unsigned int)(CODE) | ((unsigned int)(Top) << SIZE_D_CODE))
/* write out two bytes encoding the enum d_code CODE and SHORT SH. */
#define PUT_CODE_AND_SHORT(CODE,SH) \
PUT(MAKE_CODE(CODE,TOP(SH))); \
PUT(BOTTOM(SH));
#define READ_SYMBOL(leng,pack,to) \
do {char *p=alloc_relblock(leng);\
FREAD(p,1,leng,fas_stream); \
string_register->st.st_fillp = \
string_register->st.st_dim = leng; \
string_register->st.st_self = p; \
to=(pack==Cnil ? make_symbol(string_register) : intern(string_register,pack)); }while(0)
#define READ_STRING(leng,loc) \
*loc = alloc_simple_string(leng); \
(*loc)->st.st_self=alloc_relblock(leng); \
FREAD((*loc)->st.st_self,1,leng,fas_stream);
/* if try_hash finds it we don't need to write the object
Otherwise we write the index type and the object
*/
#define NUMBER_ZERO_ITEMS (SHORT_MAX - (int) d_indexed_item0)
enum circ_ind
do_hash(obj,dot)
object obj;
int dot;
{ struct htent *e;
int i;
int result;
e=gethash(obj,dump_hash_table);
if (e->hte_key==OBJNULL)
/* We won't index things unless they have < -2 in the hash table */
{ if(type_of(obj)!=t_package) return NOT_INDEXED;
sethash(obj,dump_hash_table,make_fixnum(dump_index));
e=gethash(obj,dump_hash_table);
PUT_OP(d_new_indexed_item);
DPRINTF("{dump_index=%d}",dump_index);
dump_index++;
return FIRST_INDEX;}
i = fix(e->hte_value);
if (i == -1) return NOT_INDEXED; /* don't want to index this baby */
if (dot) PUT_OP(dot);
if ( i < -1)
{ e->hte_value = make_fixnum(dump_index);
PUT_OP(d_new_indexed_item);
DPRINTF("{dump_index=%d}",dump_index);
dump_index++;
return FIRST_INDEX;
}
if (i < (NUMBER_ZERO_ITEMS))
{PUT_OP(i+(int)d_indexed_item0); return LATER_INDEX;}
if (i < (2*SHORT_MAX - (int)d_indexed_item0))
{PUT_OP((int)d_indexed_item1);
PUTD("n=%d",i- NUMBER_ZERO_ITEMS);
return LATER_INDEX;
}
if (i < SHORT_MAX*SHORT_MAX)
{PUT_OP((int)d_indexed_item2);
PUT2(i);
return LATER_INDEX;
}
if (i < SHORT_MAX*SHORT_MAX*SHORT_MAX)
{PUT_OP((int)d_indexed_item3);
PUT3(i);
return LATER_INDEX;
}
else
FEerror("too large an index");
return LATER_INDEX;
}
object
write_fasd_top(obj,x)
object x,obj;
{struct fasd *fd = (struct fasd *) x->v.v_self;
if (fd->direction == Koutput)
SETUP_FASD_IN(fd);
else FEerror("bad value for open slot of fasd");
write_fasd(obj);
/* we could really allocate a fixnum and then smash its field if this
is to costly */
(fd)->index = make_fixnum(dump_index);
return obj;
}
object
read_fasd_top(x)
object x;
{ struct fasd *fd = (struct fasd *) x->v.v_self;
int i;
VOL int e=0;
object result;
object sharp_ar1[FASD_SHARP_LIMIT];
sharp_ar=sharp_ar1;
sharp_ind = 0;
SETUP_FASD_IN(fd);
frs_push(FRS_PROTECT, Cnil);
if (nlj_active) {
e = TRUE;
goto L;
}
patch_indexed=0;
if (current_fasd.direction == Kinput)
{read_fasd1(GET_OP(),&result);
(fd)->index = make_fixnum(dump_index);
fd->direction=current_fasd.direction;
if (sharp_ind> 0)
result=fasd_patch_sharp(result);
if(patch_indexed)
{sharp_ar=current_fasd.table->v.v_self;
result=fasd_patch_sharp(result);
patch_indexed=0;
}
}
else
if(current_fasd.direction== Cnil) result= current_fasd.eof;
else
FEerror("Stream not open for input");
L:
frs_pop();
if (e) {
nlj_active = FALSE;
unwind(nlj_fr, nlj_tag);
fd->direction=Cnil;
return Cnil;
}
else
return result;
}
object Seq;
object siSPinit;
void Lmake_hash_table();
object
open_fasd(stream,direction,eof,tabl)
object stream,direction,eof,tabl;
{ object str=Cnil;
object result;
if(direction==Kinput)
{str=coerce_stream(stream,0);
if (tabl==Cnil)
tabl=alloc_simple_vector(0,aet_object);
else
check_type(tabl,t_vector);}
if(direction==Koutput)
{str=coerce_stream(stream,1);
if(tabl==Cnil) tabl=funcall_cfun(Lmake_hash_table,2,Ktest,Seq);
else
check_type(tabl,t_hashtable);}
check_type(str,t_stream);
result=alloc_simple_vector(sizeof(struct fasd)/sizeof(int),aet_object);
array_allocself(result,1,Cnil);
{struct fasd *fd= (struct fasd *)result->v.v_self;
fd->table=tabl;
fd->stream=stream;
fd->direction=direction;
fd->eof=eof;
fd->index=small_fixnum(0);
fd->package=symbol_value(Vpackage);
fd->filepos = make_fixnum(file_position(stream));
SETUP_FASD_IN(fd);
if (direction==Koutput){
PUT_OP((int)d_begin_dump);
PUTD("version=%d",FASD_VERSION);
PUT4(0); /* reserve space for the size of index array needed */
/* equivalent to: write_fasd(current_fasd.package);
except we don't want to index this, so that we can open
with an empty array.
*/
PUT_OP(d_package);
write_fasd(current_fasd.package->p.p_name);
}
else /* input */
{ object tem;
read_fasd1(GET_OP(),&tem);
if(tem!=current_fasd.table) FEerror("not positioned at beginning of a dump");
}
fd->index=make_fixnum(dump_index);
fd->filepos=current_fasd.filepos;
fd->package=current_fasd.package;
return result;
}}
object
close_fasd(ar)
object ar;
{ struct fasd *fd= (struct fasd *)(ar->v.v_self);
check_type(ar,t_vector);
if (type_of(fd->table)==t_vector)
/* input uses a vector */
{if (fd->table->v.v_self)
gset(fd->table->v.v_self,0,fix(fd->index),aet_object);
}
else
if(fd->direction==Koutput)
{clrhash(fd->table);
SETUP_FASD_IN(fd);
PUT_OP(d_end_of_file);
{int i = file_position(fd->stream);
if(type_of(fd->filepos) == t_fixnum)
{ file_position_set(fd->stream,fix(fd->filepos) +2);
/* record the length of array needed to read the indices */
PUT4(fix(fd->index));
/* move back to where we were */
file_position_set(fd->stream,i);
}}
}
/* else FEerror("bad fasd stream"); */
fd->direction=Cnil;
return ar;
}
#define HASHP(x) 1
#define TRY_HASH \
if(do_hash(obj,0)==LATER_INDEX) return;
write_fasd(obj)
object obj;
{ int j,leng;
/* hook for writing other data in fasd file */
/* check if we have already output the object in a hash table.
If so just record the index */
{
/* if dump_index is too large or the object has not been written before
we output it now */
switch(type_of(obj)){
case DP(t_cons:)
TRY_HASH;
/* decide how long we think this list is */
{object x=obj->c.c_cdr;
int l=0;
if (obj->c.c_car == siSsharp_comma)
{ PUT_OP(d_eval);
write_fasd(x);
break;}
while(1)
{ if(x==Cnil)
{PUT_OP(d_list1+l);
break;}
if(type_of(x)==t_cons)
{if ((int) d_list1 + ++l > (int) d_list4)
{PUT_OP(d_list);
break;}
else {x=x->c.c_cdr;
continue;}}
/* 1 to 4 done */
if(l==0)
{PUT_OP(d_cons);
write_fasd(obj->c.c_car);
write_fasd(obj->c.c_cdr);
return;}
else
{PUT_OP(d_list);
break;
}}}
WRITE_LIST:
write_fasd(obj->c.c_car);
obj=obj->c.c_cdr;
{int l=0;
while(1)
{if (type_of(obj)==t_cons)
{ enum circ_ind is_indexed=LATER_INDEX;
if(HASHP(t_cons)){
is_indexed=do_hash(obj,d_dot);
if (is_indexed == LATER_INDEX)
return;
if (is_indexed==FIRST_INDEX)
{ PUT_OP(d_cons);
write_fasd(obj->c.c_car);
write_fasd(obj->c.c_cdr);
return;}}
write_fasd(obj->c.c_car);
l++;
obj=obj->c.c_cdr;}
else
if(obj==Cnil)
{if (l> ((int) d_list4- (int) d_list1))
{PUT_OP(d_delimiter);}
return;}
else
{PUT_OP(d_dot);
write_fasd(obj);
return;}}}
case DP(t_symbol:)
if (obj==Cnil)
{PUT_OP(d_nil); return;}
TRY_HASH;
leng=obj->s.s_fillp;
if (current_fasd.package!=obj->s.s_hpack)
{{
if (leng< SHORT_MAX)
{PUT_OP(d_short_symbol_and_package);
PUTD("leng=%d",leng);}
else
{ j=leng;
PUT_OP(d_symbol_and_package);
PUT4(j);}}
write_fasd(obj->s.s_hpack);}
else
{ if (leng< SHORT_MAX)
{ PUT_OP(d_short_symbol);
PUTD("leng=%d",leng);}
else
{ j=leng;
PUT_OP(d_symbol);
PUT4(j);}
}
FWRITE(obj->s.s_self,1,leng,fas_stream);
break;
case DP(t_fixnum:)
leng=fix(obj);
if ((leng< (SHORT_MAX/2))
&& (leng > -(SHORT_MAX/2)))
{PUT_OP(d_short_fixnum);
PUTD("leng=%d",leng);}
else
{PUT_OP(d_fixnum);
j=leng;
PUT4(j);}
break;
case DP(t_character:)
PUT_OP(d_standard_character);
PUTD("char=%c",char_code(obj));
break;
case DP(t_string:)
leng=(obj)->st.st_fillp;
if (leng< SHORT_MAX)
{PUT_OP(d_short_string);
PUTD("leng=%d",leng);}
else
{j=leng;
PUT_OP(d_string);
PUT4(j);}
FWRITE(obj->st.st_self,1,leng,fas_stream);
break;
case DP(t_bignum:)
PUT_OP(d_bignum);
{int l = obj->big.big_length;
long *u = obj->big.big_self;
PUT4(l);
while (-- l >=0)
{PUT4(*u) ; u++;}
break;}
case DP(t_package:)
TRY_HASH;
PUT_OP(d_package);
write_fasd(obj->p.p_name);
break;
case DP(t_structure:)
TRY_HASH;
{int narg=S_DATA(obj->str.str_def)->length;
int i;
object name= S_DATA(obj->str.str_def)->name;
if(narg >= SHORT_MAX)
FEerror("Only dump structures whose length < ~a",1,make_fixnum(SHORT_MAX));
PUT_OP(d_structure);
PUTD("narg=%d",narg);
write_fasd(name);
for (i = 0; i < narg; i++)
write_fasd(structure_ref(obj,name,i));}
break;
case DP(t_array:)
TRY_HASH;
PUT_OP(d_array);
{ int leng=obj->a.a_dim;
int i;
PUT4(leng);
PUTD("elttype=%d",obj->a.a_elttype);
PUTD("rank=%d",obj->a.a_rank);
{int i;
if (obj->a.a_rank > 1)
{
for (i=0; i<obj->a.a_rank ; i++)
PUT4(obj->a.a_dims[i]);}}
for(i=0; i< leng ; i++)
write_fasd(aref(obj,i));}
break;
case DP(t_vector:)
TRY_HASH;
PUT_OP(d_vector);
{ int leng=obj->v.v_fillp;
PUT4 (leng);
PUTD("eltype=%d",obj->v.v_elttype);
{int i;
for(i=0; i< leng ; i++)
{write_fasd(aref(obj,i));}}}
break;
default:
PUT_OP(d_general_type);
prin1(obj,current_fasd.stream);
PUTD("close general:%c",')');
}}
}
/* returns 1 if the item has already been defined and this is just a reference
Also outputs the codes
*/
enum circ_ind
circular_not_first(x,dot)
object x;
int dot;
{ object *vp ;
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
if (x == *vp)
{ int ind = (vp-PRINTvs_top)/2;
if (dot) PUT_OP(dot);
if (vp[1] != Cnil)
{ if (ind < SHORT_MAX)
{PUT_OP(d_sharp_value);
PUTD("ind=%d",ind);}
else
if(ind < SHORT_MAX*SHORT_MAX)
{PUT_OP(d_sharp_value2);
PUT2(ind);}
else FEerror("Two large sharp index");
return LATER_INDEX;
}
else
{ vp[1] = Ct;
if (sharp_ind++ != ind)
FEerror("need an table to track these");
PUT_OP(d_sharp_equals);
DPRINTF("{ind=%d}",ind);
/* Don't believe I need to put the indices on the equals pass */
/* if (ind < SHORT_MAX)
{PUT_OP(d_sharp_equals);
PUTD("ind=%d",ind);}
else
if(ind < SHORT_MAX*SHORT_MAX)
{PUT_OP(d_sharp_equals2);
PUT2(ind);}
else FEerror("Two large sharp index");
*/
return FIRST_INDEX;}}
return NOT_INDEXED;}
object
fasd_patch_sharp_cons(x)
object x;
{
for (;;) {
x->c.c_car = fasd_patch_sharp(x->c.c_car);
if (type_of(x->c.c_cdr) == t_cons)
x = x->c.c_cdr;
else {
x->c.c_cdr = fasd_patch_sharp(x->c.c_cdr);
break;
}
}
}
object
fasd_patch_sharp(x)
object x;
{
cs_check(x);
switch (type_of(x)) {
case DP(t_spice:)
{ if (x->spc.spc_dummy >= FASD_SHARP_LIMIT)
FEerror("bad spice ref");
return sharp_ar[x->spc.spc_dummy ];
}
case DP(t_cons:)
/*
x->c.c_car = fasd_patch_sharp(x->c.c_car);
x->c.c_cdr = fasd_patch_sharp(x->c.c_cdr);
*/
fasd_patch_sharp_cons(x);
break;
case DP(t_vector:)
{
int i;
if ((enum aelttype)x->v.v_elttype != aet_object)
break;
for (i = 0; i < x->v.v_fillp; i++)
x->v.v_self[i] = fasd_patch_sharp(x->v.v_self[i]);
break;
}
case DP(t_array:)
{
int i, j;
if ((enum aelttype)x->a.a_elttype != aet_object)
break;
for (i = 0, j = 1; i < x->a.a_rank; i++)
j *= x->a.a_dims[i];
for (i = 0; i < j; i++)
x->a.a_self[i] = fasd_patch_sharp(x->a.a_self[i]);
break;
}
case DP(t_structure:)
{object def = x->str.str_def;
int i;
i=S_DATA(def)->length;
while (i--> 0)
structure_set(x,def,i,fasd_patch_sharp(structure_ref(x,def,i)));
break;
}
}
return(x);
}
static object sharing_table;
enum circ_ind
is_it_there(x)
object x;
{ struct htent *e;
object table=sharing_table;
switch(type_of(x)){
case t_cons:
case t_symbol:
case t_structure:
case t_array:
case t_vector:
case t_package:
e= gethash(x,table);
if (e->hte_key ==OBJNULL)
{sethash(x,table,make_fixnum(-1));
return FIRST_INDEX;
}
else
{int n=fix(e->hte_value);
if (n <0)
e->hte_value=make_fixnum(n-1);
return LATER_INDEX;}
break;
default:
return NOT_INDEXED;}}
object
find_sharing_top(x,table)
object x,table;
{sharing_table=table;
find_sharing(x);
return Ct;}
find_sharing(x)
object x;
{
cs_check(x);
BEGIN:
if(is_it_there(x)!=FIRST_INDEX) return;
switch (type_of(x)) {
case DP(t_cons:)
find_sharing(x->c.c_car);
x=x->c.c_cdr;
goto BEGIN;
break;
case DP(t_vector:)
{
int i;
if ((enum aelttype)x->v.v_elttype != aet_object)
break;
for (i = 0; i < x->v.v_fillp; i++)
find_sharing(x->v.v_self[i]);
break;
}
case DP(t_array:)
{
int i, j;
if ((enum aelttype)x->a.a_elttype != aet_object)
break;
for (i = 0, j = 1; i < x->a.a_rank; i++)
j *= x->a.a_dims[i];
for (i = 0; i < j; i++)
find_sharing(x->a.a_self[i]);
break;
}
case DP(t_structure:)
{object def = x->str.str_def;
int i;
i=S_DATA(def)->length;
while (i--> 0)
find_sharing(structure_ref(x,def,i));
break;
}
}
return;
}
object
read_fasd(i)
int i;
{object tem;
read_fasd1(i,&tem);
return tem;}
/* I am not sure if saving vs_top,vs_base is necessary */
object
lisp_eval(x)
object x;
{ object *b,*t;
SAVE_CURRENT_FASD;
b=vs_base;
t=vs_top;
vs_base=vs_top;
vs_push(x);
Leval();
x=vs_base[0];
vs_base=b;
vs_top=t;
RESTORE_FASD;
return x;
}
#define CHECK_CH(i) do{if ((i)==EOF & feof(fas_stream)) bad_eof();}while (0)
/* grow vector AR of general type */
grow_vector(ar)
object ar;
{ int len=ar->v.v_dim;
int nl=(int) (1.5*len);
char *p= (char *)AR_ALLOC(alloc_contblock,nl,object);
bcopy(ar->v.v_self,p,sizeof(object)* len);
ar->v.v_self= (object *)p;
ar->v.v_dim= ar->v.v_fillp=nl;
while(--nl >=len)
ar->v.v_self[nl]=Cnil;
}
bad_eof()
{ FEerror("Unexpected end of file",0);}
/* read one starting with byte i into location loc */
void
read_fasd1(i,loc)
object *loc;
int i;
{ object tem;
int leng;
BEGIN:
CHECK_CH(i);
switch(D_TYPE_OF(i))
{case DP(d_nil:)
*loc=Cnil;return;
case DP(d_cons:)
read_fasd1(GET_OP(),&tem);
*loc=make_cons(tem,Cnil);
loc= &((*loc)->c.c_cdr);
i=GET_OP();
goto BEGIN;
case DP(d_list1:) i=1;goto READ_LIST;
case DP(d_list2:) i=2;goto READ_LIST;
case DP(d_list3:) i=3;goto READ_LIST;
case DP(d_list4:) i=4;goto READ_LIST;
case DP(d_list:) i=(1<<30) ; goto READ_LIST;
READ_LIST:
while(1)
{int j;
if (--i < 0) {*loc=Cnil; return;}
DP(reading_list:) ;
j=GET_OP();
CHECK_CH(j);
if (j==d_delimiter)
{*loc=Cnil;
DPRINTF("{Read end of list(%d)}",i);
return;}
else
if(j==d_dot)
{ DPRINTF("{Read end of dotted list(%d)}",i);
read_fasd1(GET_OP(),loc);
return;}
else
{object tem;
DPRINTF("{Read next item in list(%d)}",i);
read_fasd1(j,&tem);
DPRINTF("{Item=",(debug >= 2 ? pp(tem) : 0));
DPRINTF("}",0);
*loc=make_cons(tem,Cnil);
loc= &((*loc)->c.c_cdr);}}
case DP(d_delimiter:)
case DP(d_dot:)
FEerror("Illegal op at top level");
break;
case DP(d_eval_skip:)
read_fasd1(GET_OP(),loc);
if(patch_indexed > 0)
{sharp_ar=current_fasd.table->v.v_self;
*loc=fasd_patch_sharp(*loc);}
lisp_eval(*loc);
read_fasd1(GET_OP(),loc);
break;
case d_macro:
*loc=ifuncall1(current_fasd.macro,current_fasd.stream);
break;
case d_reserve1:
case d_reserve2:
case d_reserve3:
case d_reserve4:
FEerror("Op reserved for future use");
break;
case DP(d_reset_index:)
dump_index=0;
break;
case DP(d_short_symbol:)
leng=GETD("leng=%d");
leng = LENGTH(i,leng);
READ_SYMBOL(leng,current_fasd.package,tem);
*loc=tem;
return ;
case DP(d_short_symbol_and_package:)
{object pack;
leng=GETD("leng=%d");
leng = LENGTH(i,leng);
read_fasd1(GET_OP(),&pack);
READ_SYMBOL(leng,pack,tem);
*loc=tem;
return;}
case DP(d_short_string:)
leng=GETD("leng=%d");
leng = LENGTH(i,leng);
READ_STRING(leng,loc);
return;
case DP(d_string:)
{int j;
GET4(j);
READ_STRING(j,loc);
return;}
case DP(d_indexed_item3:)
GET3(i);goto INDEXED;
case DP(d_indexed_item2:)
GET2(i);goto INDEXED;
case DP(d_indexed_item1:)
i=GET()+ NUMBER_ZERO_ITEMS ; goto INDEXED;
default:
case DP(d_indexed_item0:)
i = i - (int) d_indexed_item0; goto INDEXED;
INDEXED:
*loc= current_fasd.table->v.v_self[i];
/* if object not yet built make pointer to it */
if(*loc==0)
{*loc=current_fasd.table->v.v_self[i]= alloc_object(t_spice);
(*loc)->spc.spc_dummy= i;
patch_indexed=1;}
return;
/* the item`s' case does not return a value but is simply
a facility to allow convenient dumping of a list of registers
at the beginning, follwed by a delimiter. read continues on. */
case DP(d_new_indexed_items:)
case DP(d_new_indexed_item:)
{object tem;
int cindex,k;
k=GET_OP();
MORE:
cindex =dump_index;
DPRINTF("{dump_index=%d}",dump_index);
if (dump_index >= current_fasd.table->v.v_dim)
grow_vector(current_fasd.table);
/* grow the array */
current_fasd.table->v.v_self[dump_index++] = 0;
read_fasd1(k,loc);
current_fasd.table->v.v_self[cindex] = *loc;
if (i==d_new_indexed_items)
{int k=GET_OP();
if (k==d_delimiter)
{ DPRINTF("{Reading last of new indexed items}",0);
read_fasd1(GET_OP(),loc);
return;}
else {
goto MORE;
}}
return;
}
case DP(d_short_fixnum:)
{int leng=GETD("n=%d");
if (leng & (1 << (SIZE_SHORT -1)))
leng= leng - (1 << (SIZE_SHORT));
*loc=make_fixnum(leng);
return;}
case DP(d_fixnum:)
{int j;
GET4(j);
*loc=make_fixnum(j);
return;}
case DP( d_bignum:)
{int j;
object tem;
long *u;
GET4(j);
tem = alloc_object(t_bignum);
tem->big.big_length = j;
tem-> big.big_self = 0;
u = tem-> big.big_self = (long *) alloc_relblock(j*sizeof(long));
while ( --j >=0)
{ GET4(*u);
u++;}
*loc=tem; return;}
case DP(d_objnull:)
*loc=0; return;
case DP(d_structure:)
{ int narg,i,tem;
object name;
narg=GETD("narg=%d");
read_fasd1(GET_OP(),& name);
{ object *base=vs_top;
object *p = base;
vs_base=base;
vs_top = base + 1 + narg;
*p++ = name;
for (i=0; i < narg ; i++)
read_fasd1(GET_OP(),p++);
vs_base=base;
vs_top = p;
siLmake_structure();
*loc = vs_base[0];
vs_top=vs_base=base;
return;
}}
case DP(d_symbol:)
{int i; object tem;
GET4(i);
READ_SYMBOL(i,current_fasd.package,tem);
*loc=tem;
return ;}
case DP(d_symbol_and_package:)
{int i; object pack;
GET4(i);
read_fasd1(GET_OP(),&pack);
READ_SYMBOL(i,pack,*loc);
return;}
case DP(d_package:)
{object pack,tem;
read_fasd1(GET_OP(),&tem);
pack=find_package(tem);
if (pack==Cnil) FEerror("The package named ~a, does not exist",1,tem);
*loc=pack;
return ;}
case DP(d_standard_character:)
*loc=(code_char(GETD("char=%c")));
return;
case DP(d_vector:)
{int leng,j;
object y;
object x=alloc_object(t_vector);
GET4(leng);
x->v.v_elttype = GETD("v_elttype=%d");
x->v.v_dim=x->v.v_fillp=leng;
x->v.v_self=0;
x->v.v_displaced=Cnil;
x->v.v_hasfillp=x->v.v_adjustable=0;
array_allocself(x,0,Cnil);
for (j=0; j< leng ; j++)
{ DPRINTF("{vector_elt=%d}",j);
read_fasd1(GET_OP(),&y);
aset(x,j,y);}
*loc=x;
DPRINTF("{End of length %d vector}",leng);
return;}
case DP(d_array:)
{int leng,i;
object y;
object x=alloc_object(t_array);
GET4(leng);
x->a.a_elttype = GETD("a_elttype=%d");
x->a.a_dim=leng;
x->a.a_rank= GETD("a_rank=%d");
x->a.a_self=0;
x->a.a_displaced=Cnil;
x->a.a_adjustable=0;
if (x->a.a_rank > 0)
{ x->a.a_dims = (int *)alloc_relblock(sizeof(int)*(x->a.a_rank)); }
for (i=0; i< x->a.a_rank ; i++)
GET4(x->a.a_dims[i]);
array_allocself(x,0,Cnil);
for (i=0; i< leng ; i++)
{ read_fasd1(GET_OP(),&y);
aset(x,i,y);}
*loc=x;
return;}
case DP(d_end_of_file:)
current_fasd.direction =Cnil;
*loc=current_fasd.eof;
return;
case DP(d_begin_dump:)
{int vers=GETD("version=%d");
object tem;
if(vers!=FASD_VERSION)
FEerror("This file was dumped with FASD version ~a not ~a.",
2,make_fixnum(vers),make_fixnum(FASD_VERSION));}
{int leng;
GET4(leng);
current_fasd.table_length=make_fixnum(leng);}
read_fasd1(GET_OP(),&tem);
if (type_of(tem)==t_package || tem==Cnil)
{current_fasd.package = tem;
*loc=current_fasd.table;}
else FEerror("expected package");
return;
case DP(d_general_type:)
*loc=read_object_non_recursive(current_fasd.stream);
if(GETD("close general:%c")!=')') FEerror("general type not followed by ')'");
return;
case DP(d_sharp_equals:)
i=sharp_ind;
if (i >= FASD_SHARP_LIMIT -1)
FEerror("Exceeded FASD SHARP LIMIT.", 0);
sharp_ar[++sharp_ind] = 0;
sharp_ar[i] = alloc_object(t_spice);
sharp_ar[i]->spc.spc_dummy = i;
read_fasd1(GET_OP(),loc);
sharp_ar[i]= *loc;
return;
case DP(d_sharp_value2:) GET2(i); goto SHARP_VALUE;
case DP(d_sharp_value:) i=GETD("ind=%d"); goto SHARP_VALUE;
SHARP_VALUE:
if (i >= FASD_SHARP_LIMIT)
FEerror("Too many circularities definitions.", 0);
*loc=sharp_ar[i];
return;
/* Special type, the forms have been sharp patched separately
It is also arranged that it does not
*/
case DP(d_enter_vector:)
{object *base=vs_top,x,y;
while ((i=GET_OP()) !=d_delimiter)
{int eval=(i==d_eval_skip);
sharp_ind=0;
if(eval) i=GET_OP();
read_fasd1(i,vs_top++);
if(sharp_ind> 0) vs_top[-1]=fasd_patch_sharp(vs_top[-1]);
/* the eval entries don't enter it */
if(eval) lisp_eval(*(--vs_top));
vs_check;}
x=alloc_simple_vector(vs_top-base,aet_object);
x->v.v_self=(object *)alloc_relblock(sizeof (object) *(vs_top-base));
for(i=0; i<x->v.v_fillp; i++)
x->v.v_self[i]=base[i];
vs_top=base;
*loc=x;
return;
}
case DP(d_eval:)
{object tem;
read_fasd1(GET_OP(),&tem);
if (sharp_ind > 0) tem=fasd_patch_sharp(tem);
*loc = lisp_eval(tem);
return;
}
}}
clrhash(table)
object table;
{int i;
if (table->ht.ht_nent > 0 )
for(i = 0; i < table->ht.ht_size; i++) {
table->ht.ht_self[i].hte_key = OBJNULL;
table->ht.ht_self[i].hte_value = OBJNULL;}
table->ht.ht_nent =0;}
object read_fasl_vector1();
object
read_fasl_vector(in)
object in;
{char ch;
while (1)
{ ch=readc_stream(in);
if (ch=='#')
{unreadc_stream(ch,in);
return read_fasl_vector1(in);}
if (ch== d_begin_dump){
unreadc_stream(ch,in);
break;}}
{object ar=open_fasd(in,Kinput,0,Cnil);
int n=fix(current_fasd.table_length);
object result,tem,last;
#ifdef HAVE_ALLOCA
current_fasd.table->v.v_self
= (object *)alloca(n*sizeof(object));
#else
current_fasd.table->v.v_self
= (object *)alloc_relblock(n*sizeof(object));
#endif
current_fasd.table->v.v_dim=n;
current_fasd.table->v.v_fillp=n;
gset( current_fasd.table->v.v_self,0,n,aet_object);
result=read_fasd_top(ar);
if (type_of(result) !=t_vector) goto ERROR;
last=result->v.v_self[result->v.v_fillp-1];
if(type_of(last)!=t_cons || last->c.c_car !=siSPinit)
goto ERROR;
current_fasd.table->v.v_self = 0;
close_fasd(ar);
return result;
ERROR: FEerror("Bad fasd stream ~a",1,in);
return Cnil;
}}
/*
static object
fasd_i_macro(x)
object x;
{object tem;
tem=assoc_eq(tem,siVPinit->s.s_dbind);
if (tem!=Cnil)
{object y=tem->c.c_cdr->c.c_car;
check_type(y,t_fixnum);
PUT_OP(d_macro);
PUT2(fix(y));
return Ct;}
return Cnil;}
*/
init_fasdump()
{
make_si_sfun("READ-FASD-TOP",read_fasd_top,1);
make_si_sfun("WRITE-FASD-TOP",write_fasd_top,2);
make_si_sfun("OPEN-FASD",open_fasd,4);
make_si_sfun("CLOSE-FASD",close_fasd,1);
/* make_si_sfun("FASD-I-DATA",fasd_i_macro,1); */
make_si_sfun("FIND-SHARING-TOP",find_sharing_top,2);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.