<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

Gbp-Pq: Name list_order.16

diff --git a/h/protoize.h b/h/protoize.h
index 24f4cd73ef212e81f23759f90f1fb656e2d11a0e..88455944bbdd063febc9743210ee43915b44f9cb 100644 (file)
--- 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 4b49309fbebc6bd7d01a6dd42b90ef1bddd8301d..4f199ad9fb21a3a5d7f2f1d0b83bf653058d43ce 100755 (executable)
--- 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 771aa9874d37998c6fc245e00bbadb98ba0aaa36..9b1818469c091b4cc106ac80ff8cc203a6e2d86b 100755 (executable)
--- 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;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));
 
 }