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 make_pathname ();
static int needs_patching;
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 sKinput or sKoutput */
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 evald_items; /* a list of items which have been eval'd and must
not be walked by fasd_patch_sharp */
};
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; \
int old_needs_patching = needs_patching; \
old_fd = current_fasd;
#define RESTORE_FASD \
current_fasd =old_fd ; \
dump_index= old_dump_index ; \
needs_patching = old_needs_patching ; \
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;
int
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)
void
putd(str,i)
char *str;
int i;
{if (debug)
{printf("{");
printf(str,i);
printf("}");}
putc(i,fas_stream);}
void
putc1(x)
int x;
{ if (debug) printf("(%x,%d,%c)",x,x,x);
putc(x,fas_stream);
fflush(stdout);
}
int
getc1()
{ int x;
x= getc(fas_stream);
if (debug) printf("(%x,%d,%c)",x,x,x);
fflush(stdout);
return x;
}
int
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;
}
int
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;
}
#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)
int
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 { BEGIN_NO_INTERRUPT;{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)); \
END_NO_INTERRUPT;} \
}while(0)
#define READ_STRING(leng,loc) do {BEGIN_NO_INTERRUPT; \
*loc = alloc_simple_string(leng); \
(*loc)->st.st_self=alloc_relblock(leng); END_NO_INTERRUPT; \
FREAD((*loc)->st.st_self,1,leng,fas_stream);} while(0)
/* 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",0);
return LATER_INDEX;
}
void write_fasd();
object
write_fasd_top(obj,x)
object x,obj;
{struct fasd *fd = (struct fasd *) x->v.v_self;
if (fd->direction == sKoutput)
SETUP_FASD_IN(fd);
else FEerror("bad value for open slot of fasd",0);
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;
}
/* It is assumed that anything passed to eval should be first
sharp patched, and that there will be no more patching afterwards.
The object returned might have arbitrary complexity.
*/
#define MAYBE_PATCH(result) \
if (needs_patching) result =fasd_patch_sharp(result,0)
object
read_fasd_top(x)
object x;
{ struct fasd *fd = (struct fasd *) x->v.v_self;
VOL int e=0;
object result;
SAVE_CURRENT_FASD;
SETUP_FASD_IN(fd);
frs_push(FRS_PROTECT, Cnil);
if (nlj_active) {
e = TRUE;
goto L;
}
needs_patching=0;
if (current_fasd.direction == sKinput)
{read_fasd1(GET_OP(),&result);
MAYBE_PATCH(result);
(fd)->index = make_fixnum(dump_index);
fd->direction=current_fasd.direction;
}
else
if(current_fasd.direction== Cnil) result= current_fasd.eof;
else
FEerror("Stream not open for input",0);
L:
frs_pop();
if (e) {
nlj_active = FALSE;
unwind(nlj_fr, nlj_tag);
fd->direction=Cnil;
RESTORE_FASD;
return Cnil;
}
else
{ RESTORE_FASD;
return result;}
}
object sLeq;
object sSPinit;
void Lmake_hash_table();
object
open_fasd(stream,direction,eof,tabl)
object stream,direction,eof,tabl;
{ object str=Cnil;
object result;
if(direction==sKinput)
{str=coerce_stream(stream,0);
if (tabl==Cnil)
tabl=alloc_simple_vector(0,aet_object);
else
check_type(tabl,t_vector);}
if(direction==sKoutput)
{str=coerce_stream(stream,1);
if(tabl==Cnil) tabl=funcall_cfun(Lmake_hash_table,2,sKtest,sLeq);
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(sLApackageA);
fd->filepos = make_fixnum(file_position(stream));
SETUP_FASD_IN(fd);
if (direction==sKoutput){
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",0);
}
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==sKoutput)
{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",0); */
fd->direction=Cnil;
return ar;
}
#define HASHP(x) 1
#define TRY_HASH \
if(do_hash(obj,0)==LATER_INDEX) return;
void
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;
plong *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",')');
}}
}
static void
fasd_patch_sharp_cons(x,depth)
int depth;
object x;
{
for (;;) {
x->c.c_car = fasd_patch_sharp(x->c.c_car,depth+1);
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,depth+1);
break;
}
}
}
object
fasd_patch_sharp(x,depth)
object x;
{
cs_check(x);
if (++depth > 1000)
{ object *p = current_fasd.table->v.v_self;
while(*p)
{ if (x== *p++ && type_of(x)!=t_spice) return x;}}
/* eval'd forms are already patched, and they might contain
circular structure */
{ object p = current_fasd.evald_items;
while (p != Cnil)
{ if (p->c.c_car == x) return x;
p = p->c.c_cdr;}}
switch (type_of(x)) {
case DP(t_spice:)
{ if (x->spc.spc_dummy >= current_fasd.table->v.v_dim)
FEerror("bad spice ref",0);
return current_fasd.table->v.v_self[x->spc.spc_dummy ];
}
case DP(t_cons:)
/*
x->c.c_car = fasd_patch_sharp(x->c.c_car,depth);
x->c.c_cdr = fasd_patch_sharp(x->c.c_cdr,depth);
*/
fasd_patch_sharp_cons(x,depth);
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],depth);
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],depth);
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),depth));
break;
}
default:
/* dont have to walk other objs */
break;
}
return(x);
}
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;}}
static void
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
find_sharing_top(x,table)
object x,table;
{sharing_table=table;
find_sharing(x);
return Ct;
}
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 */
static void
grow_vector(ar)
object ar;
{ int len=ar->v.v_dim;
int nl=(int) (1.5*len);
{BEGIN_NO_INTERRUPT;
{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;
END_NO_INTERRUPT;}}
}
static void
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",0);
break;
case DP(d_eval_skip:)
read_fasd1(GET_OP(),loc);
MAYBE_PATCH(*loc);
lisp_eval(*loc);
read_fasd1(GET_OP(),loc);
break;
case d_reserve1:
case d_reserve2:
case d_reserve3:
case d_reserve4:
FEerror("Op reserved for future use",0);
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;
needs_patching=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;
plong *u;
GET4(j);
{ BEGIN_NO_INTERRUPT;
tem = alloc_object(t_bignum);
tem->big.big_length = j;
tem-> big.big_self = 0;
u = tem-> big.big_self = (plong *) alloc_relblock(j*sizeof(plong));
END_NO_INTERRUPT;
}
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:)
{BEGIN_NO_INTERRUPT;
{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);
END_NO_INTERRUPT;
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",0);
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 ')'",0);
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;
extern object sSPmemory;
int print_only=0;
int n = 0;
object vv = sSPmemory->s.s_dbind,tem;
if (vv == Cnil) print_only = 1;
else
if (type_of(vv)!=t_cfdata) FEerror("bad VectorToEnter",0);
while ((i=GET_OP()) !=d_delimiter)
{int eval=(i==d_eval_skip);
if (print_only)
{ if (eval) princ_str("#!",Ct);
else if (i== d_eval)
princ_str("#.",Ct);}
if(eval) i=GET_OP();
read_fasd1(i, &tem);
MAYBE_PATCH(tem);
/* the eval entries don't enter it */
if (print_only) {princ(tem,Ct);
princ_str(";",Ct);
princ(make_fixnum(n),Ct);
if (eval==0) n++;
princ_str("\n",Ct);}
else
{
if(eval)
lisp_eval(tem);
else
{if (n >= vv->cfd.cfd_fillp) FEerror("cfd too small",0);
vv->cfd.cfd_self[n++]=tem;}}}
if (print_only==0) vv->cfd.cfd_fillp = n;
*loc=vv;
return;
}
case DP(d_eval:)
{object tem;
read_fasd1(GET_OP(),&tem);
MAYBE_PATCH(tem);
*loc = lisp_eval(tem);
current_fasd.evald_items = make_cons(*loc,current_fasd.evald_items);
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;
object orig = in;
object d;
int tem;
if (((tem=getc(in->sm.sm_fp)) == EOF) && feof(in->sm.sm_fp))
{ d = coerce_to_pathname(in);
d = make_pathname(d->pn.pn_host,
d->pn.pn_device,
d->pn.pn_directory,
d->pn.pn_name,
make_simple_string("data"),
d->pn.pn_version);
d = coerce_to_namestring(d);
in = open_stream(d,smm_input,Cnil,Cnil);
if (in == Cnil)
FEerror("Can't open file ~s",1,d);
}
else if (tem != EOF)
{ ungetc(tem,in->sm.sm_fp);}
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,sKinput,0,Cnil);
int n=fix(current_fasd.table_length);
object result,tem,last;
{ BEGIN_NO_INTERRUPT;
#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);
END_NO_INTERRUPT;
}
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 !=sSPinit)
goto ERROR;
current_fasd.table->v.v_self = 0;
close_fasd(ar);
if (orig != in)
close_stream(in);
return result;
ERROR: FEerror("Bad fasd stream ~a",1,in);
return Cnil;
}}
object IfaslInStream;
void
IreadFasdData()
/* While executing this the siPMemory should be bound to the cfdata
and the sSPinit to a vector of addresses. */
{object ar=open_fasd(IfaslInStream,sKinput,0,Cnil);
int n=fix(current_fasd.table_length);
object result,tem,last;
{BEGIN_NO_INTERRUPT;
#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);
END_NO_INTERRUPT;
}
result=read_fasd_top(ar);
/* make sure there is nothing still pointing into the stack */
current_fasd.table->v.v_self = 0;
current_fasd.table->v.v_dim=0;
current_fasd.table->v.v_fillp=0;
}
void
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.