From 6b88e38ac002546eeb113ae548287ec8a8891207 Mon Sep 17 00:00:00 2001 From: Camm Maguire Date: Thu, 11 Aug 2022 18:16:42 +0100 Subject: [PATCH] TODO: Put a short summary on the line above and replace this paragraph with a longer explanation of this change. Complete the meta-information with other relevant fields (see below for details). To make it easier, the information below has been extracted from the changelog. Adjust it or drop it. gcl (2.6.12-58) unstable; urgency=medium * list_order.14 Gbp-Pq: Name list_order.16 --- h/protoize.h | 6 ++ o/fasdump.c | 95 ++---------------------------- o/print.d | 163 ++++++++++++++++++++++++++------------------------- 3 files changed, 94 insertions(+), 170 deletions(-) diff --git a/h/protoize.h b/h/protoize.h index 24f4cd7..8845594 100644 --- a/h/protoize.h +++ b/h/protoize.h @@ -1964,3 +1964,9 @@ vsystem(const char *); object n_cons_from_x(fixnum,object); + +int +seek_to_end_ofile(FILE *); + +void +travel_find_sharing(object,object); diff --git a/o/fasdump.c b/o/fasdump.c index 4b49309..4f199ad 100755 --- a/o/fasdump.c +++ b/o/fasdump.c @@ -976,100 +976,13 @@ fasd_patch_sharp(object x, int depth) } object sharing_table; -static enum circ_ind -is_it_there(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(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; - } - default: - break; - } - return; -} - -DEFUN_NEW("FIND-SHARING-TOP",object,fSfind_sharing_top,SI,2,2,NONE,OO,OO,OO,OO,(object x, object table),"") -/* static object */ -/* FFN(find_sharing_top)(object x, object table) */ -{sharing_table=table; - find_sharing(x); - return Ct; +DEFUN_NEW("FIND-SHARING-TOP",object,fSfind_sharing_top,SI,2,2,NONE,OO,OO,OO,OO,(object x, object table),"") { + sharing_table=table; + travel_find_sharing(x,table); + return Ct; } - - - - /* static object */ /* read_fasd(int i) */ /* {object tem; */ diff --git a/o/print.d b/o/print.d index 771aa98..9b18184 100755 --- a/o/print.d +++ b/o/print.d @@ -490,7 +490,6 @@ int level; void (*wf)(int) = write_ch_fun; object *vt = PRINTvs_top; - object *vl = PRINTvs_limit; bool e = PRINTescape; bool ra = PRINTreadably; bool r = PRINTradix; @@ -599,7 +598,6 @@ L: PRINTradix = r; PRINTescape = e; PRINTreadably = ra; - PRINTvs_limit = vl; PRINTvs_top = vt; write_ch_fun = wf; @@ -702,18 +700,19 @@ print_symbol_name_body(object x) { #define FOUND -1 static int -do_write_sharp_eq(object x,bool dot) { +do_write_sharp_eq(struct htent *e,bool dot) { - bool defined=x->c.c_cdr!=Cnil; + fixnum val=fix(e->hte_value); + bool defined=val&1; if (dot) { write_str(" . "); if (!defined) return FOUND; } - x->c.c_cdr=Ct; + if (!defined) e->hte_value=make_fixnum(val|1); write_ch('#'); - write_decimal(fix(x->c.c_car)); + write_decimal(val>>1); write_ch(defined ? '#' : '='); return defined ? DONE : FOUND; @@ -726,7 +725,7 @@ write_sharp_eq(object x,bool dot) { struct htent *e; return PRINTvs_top[0]!=Cnil && (e=gethash(x,PRINTvs_top[0]))->hte_key!=OBJNULL ? - do_write_sharp_eq(e->hte_value,dot) : 0; + do_write_sharp_eq(e,dot) : 0; } @@ -1392,79 +1391,65 @@ int level; } } -static int dgs; +static int dgs,dga; #include "page.h" -#define travel_seen(x) x->d.m -#define travel_pushed(x) x->d.f -#define travel_bits(x) x->md.mf - static void travel_push(object x) { int i; - if (NULL_OR_ON_C_STACK(x)) + if (is_imm_fixnum(x)) return; - if (travel_seen(x)) { + if (is_marked(x)) { - if (!travel_pushed(x)) { + if (imcdr(x) || !x->d.f) vs_check_push(x); - travel_pushed(x)=1; - } - - return; + if (!imcdr(x)) + x->d.f=1; - } - - switch (type_of(x)) { + } else switch (type_of(x)) { - case t_symbol: + case t_symbol: - if (dgs && x->s.s_hpack==Cnil) - travel_seen(x)=1; - break; - - case t_cons: - - { - object y=x->c.c_cdr; - travel_seen(x)=1; - travel_push(x->c.c_car); - travel_push(y); - } - break; + if (dgs && x->s.s_hpack==Cnil) { + mark(x); + } + break; - case t_array: + case t_cons: - travel_seen(x)=1; - if ((enum aelttype)x->a.a_elttype == aet_object) - for (i=0;ia.a_dim;i++) - travel_push(x->a.a_self[i]); - break; + { + object y=x->c.c_cdr; + mark(x); + travel_push(x->c.c_car); + travel_push(y); + } + break; - case t_vector: + case t_vector: + case t_array: - travel_seen(x)=1; - if ((enum aelttype)x->v.v_elttype == aet_object) - for (i=0;iv.v_fillp;i++) - travel_push(x->v.v_self[i]); - break; + mark(x); + if (dga && (enum aelttype)x->a.a_elttype==aet_object) + for (i=0;ia.a_dim;i++) + travel_push(x->a.a_self[i]); + break; - case t_structure: + case t_structure: - travel_seen(x)=1; - for (i = 0; i < S_DATA(x->str.str_def)->length; i++) - travel_push(structure_ref(x,x->str.str_def,i)); - break; + mark(x); + for (i = 0; i < S_DATA(x->str.str_def)->length; i++) + travel_push(structure_ref(x,x->str.str_def,i)); + break; - default: + default: - break; + break; - } + } } @@ -1474,10 +1459,15 @@ travel_clear(object x) { int i; - if (NULL_OR_ON_C_STACK(x) || !travel_bits(x)) + if (is_imm_fixnum(x)) + return; + + if (!is_marked(x)) return; - travel_bits(x)=0; + unmark(x); + if (!imcdr(x)) + x->d.f=0; switch (type_of(x)) { @@ -1487,20 +1477,14 @@ travel_clear(object x) { travel_clear(x->c.c_cdr); break; + case t_vector: case t_array: - if ((enum aelttype)x->a.a_elttype == aet_object) + if (dga && (enum aelttype)x->a.a_elttype == aet_object) for (i=0;ia.a_dim;i++) travel_clear(x->a.a_self[i]); break; - case t_vector: - - if ((enum aelttype)x->v.v_elttype == aet_object) - for (i=0;iv.v_fillp;i++) - travel_clear(x->v.v_self[i]); - break; - case t_structure: for (i = 0; i < S_DATA(x->str.str_def)->length; i++) @@ -1515,26 +1499,47 @@ travel_clear(object x) { } -object sLeq; - static void -setupPRINTcircle(object x,int dogensyms) { - - object *xp; +travel(object x,int mdgs,int mdga) { BEGIN_NO_INTERRUPT; - dgs=dogensyms; + dgs=mdgs; + dga=mdga; travel_push(x); - dgs=0; - PRINTvs_limit = vs_top; travel_clear(x); END_NO_INTERRUPT; - vs_check_push(PRINTvs_limit>PRINTvs_top ? funcall_cfun(Lmake_hash_table,2,sKtest,sLeq) : Cnil); - for (xp=PRINTvs_top;xpvp ? funcall_cfun(Lmake_hash_table,2,sKtest,sLeq) : Cnil; + for (j=0;vhte_key==OBJNULL) + sethash(*v,h,make_fixnum((j++)<<1)); + + vs_top=vp; + vs_push(h); + +} + +void +travel_find_sharing(object x,object table) { + + object *vp=vs_top; + + travel(x,1,1); + + for (;vs_top>vp;vs_top--) + sethash(vs_head,table,make_fixnum(-2)); } -- 2.30.2