Description: <short summary of the 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
Author: Camm Maguire <camm@debian.org>
---
The information above should follow the Patch Tagging Guidelines, please
checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
are templates for supplementary fields that you might want to add:
Origin: <vendor|upstream|other>, <url of original patch>
Bug: <url in upstream bugtracker>
Bug-Debian: https://bugs.debian.org/<bugnumber>
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
Forwarded: <no|not-needed|url proving that it has been forwarded>
Reviewed-By: <name and email of someone who approved the patch>
Last-Update: 2018-01-12
--- gcl-2.6.12.orig/h/protoize.h
+++ gcl-2.6.12/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);
--- gcl-2.6.12.orig/o/fasdump.c
+++ gcl-2.6.12/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; */
--- gcl-2.6.12.orig/o/print.d
+++ gcl-2.6.12/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;i<x->a.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;i<x->v.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;i<x->a.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;i<x->a.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;i<x->v.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;xp<PRINTvs_limit;xp++)
- sethash(*xp,vs_head,MMcons(make_fixnum(xp-PRINTvs_top),Cnil));
- PRINTvs_top[0]=vs_head;
- PRINTvs_limit=vs_top=PRINTvs_top+1;
+}
+
+object sLeq;
+
+static void
+setupPRINTcircle(object x,int dogensyms) {
+
+ object *vp=vs_top,*v=vp,h;
+ fixnum j;
+
+ travel(x,dogensyms,PRINTarray);
+
+ h=vs_top>vp ? funcall_cfun(Lmake_hash_table,2,sKtest,sLeq) : Cnil;
+ for (j=0;v<vs_top;v++)
+ if (!imcdr(*v) || gethash(*v,h)->hte_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));
}