🚀 go-pugleaf

  We have an application coded in EmacsLisp that contains many lists and
vectors that end up pointing to themselves. The standard emacs-18.57
can not print these objects. In addition, the following code cause emacs
to abort

  (setq a '[nil])
  (setq b '[nil])
  (aset a 0 a)
  (aset b 0 b)
  (equal a b)
  
The problem being that equal does not take into consideration that the
vectors (or lists for that matter) may be circular.

  If you want to be able to use circular lists and/or vectors the
following changes to print.c and fns.c will allow you to print and/or
use the function equal.

*** fns.c.orig	Wed Aug  7 08:13:13 1991
--- fns.c	Wed Aug  7 08:18:40 1991
***************
*** 772,777 ****
--- 772,781 ----
    return val;
  }
  
+ #define EQUAL_DEPTH 200
+ int equal_depth;
+ Lisp_Object equal_objs1[EQUAL_DEPTH], equal_objs2[EQUAL_DEPTH];
+ 
  DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
    "T if two Lisp objects have similar structure and contents.\n\
  They must have the same data type.\n\
***************
*** 779,786 ****
  Vectors and strings are compared element by element.\n\
  Numbers are compared by value.  Symbols must match exactly.")
    (o1, o2)
!      register Lisp_Object o1, o2;
  {
  do_cdr:
    QUIT;
    if (XTYPE (o1) != XTYPE (o2)) return Qnil;
--- 783,830 ----
  Vectors and strings are compared element by element.\n\
  Numbers are compared by value.  Symbols must match exactly.")
    (o1, o2)
!      Lisp_Object o1, o2;
  {
+   equal_depth = 0;
+   return equal_circular(o1, o2);
+ }
+ 
+ Lisp_Object
+ equal_circular(o1, o2)
+ Lisp_Object o1,o2;
+ /* called on objects that are possibly circular */
+ {
+   Lisp_Object ret;
+   int i1 = -1, i2 = -1;
+   int i;
+   for (i = 0; i < equal_depth; i++) {
+     if (EQ(o1,equal_objs1[i])) {
+       i1 = i;
+       i = equal_depth;
+     }
+   }
+   for (i = 0; i < equal_depth; i++) {
+     if (EQ(o2,equal_objs2[i])) {
+       i2 = i;
+       i = equal_depth;
+     }
+   }
+   if ( i1 != i2) return Qnil;
+   if ( i1 >= 0) return Qt;
+   equal_objs1[equal_depth] = o1;
+   equal_objs2[equal_depth] = o2;
+   if (++equal_depth == EQUAL_DEPTH) {
+     error ("Apparently circular structures being equaled");
+   };
+   ret = equal (o1, o2);
+   equal_depth--;
+   return ret;
+ }
+ 
+ Lisp_Object
+ equal(o1, o2)
+ register Lisp_Object o1, o2;
+ {
  do_cdr:
    QUIT;
    if (XTYPE (o1) != XTYPE (o2)) return Qnil;
***************
*** 788,794 ****
    if (XTYPE (o1) == Lisp_Cons)
      {
        Lisp_Object v1;
!       v1 = Fequal (Fcar (o1), Fcar (o2));
        if (NULL (v1))
  	return v1;
        o1 = Fcdr (o1), o2 = Fcdr (o2);
--- 832,838 ----
    if (XTYPE (o1) == Lisp_Cons)
      {
        Lisp_Object v1;
!       v1 = equal_circular (Fcar (o1), Fcar (o2));
        if (NULL (v1))
  	return v1;
        o1 = Fcdr (o1), o2 = Fcdr (o2);
***************
*** 810,816 ****
  	  Lisp_Object v, v1, v2;
  	  v1 = XVECTOR (o1)->contents [index];
  	  v2 = XVECTOR (o2)->contents [index];
! 	  v = Fequal (v1, v2);
  	  if (NULL (v)) return v;
  	}
        return Qt;
--- 854,860 ----
  	  Lisp_Object v, v1, v2;
  	  v1 = XVECTOR (o1)->contents [index];
  	  v2 = XVECTOR (o2)->contents [index];
! 	  v = equal_circular (v1, v2);
  	  if (NULL (v)) return v;
  	}
        return Qt;

*** print.c.orig	Wed Aug  7 13:01:48 1991
--- print.c	Wed Aug  7 13:01:53 1991
***************
*** 35,40 ****
--- 35,43 ----
  
  /* Avoid actual stack overflow in print.  */
  int print_depth;
+ #define PRINT_CIRCLE 200
+ int circ_depth;
+ Lisp_Object circ_objs[PRINT_CIRCLE];
  
  /* Maximum length of list to print in full; noninteger means
     effectively infinity */
***************
*** 347,352 ****
--- 350,356 ----
      printcharfun = Vstandard_output;
    PRINTPREPARE;
    print_depth = 0;
+   circ_depth = 0;
    print (obj, printcharfun, 1);
    PRINTFINISH;
    return obj;
***************
*** 371,376 ****
--- 375,381 ----
    printcharfun = Vprin1_to_string_buffer;
    PRINTPREPARE;
    print_depth = 0;
+   circ_depth = 0;
    print (obj, printcharfun, 1);
    /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
    PRINTFINISH;
***************
*** 400,405 ****
--- 405,411 ----
      printcharfun = Vstandard_output;
    PRINTPREPARE;
    print_depth = 0;
+   circ_depth = 0;
    print (obj, printcharfun, 0);
    PRINTFINISH;
    return obj;
***************
*** 428,433 ****
--- 434,440 ----
    GCPRO1 (obj);
    PRINTPREPARE;
    print_depth = 0;
+   circ_depth = 0;
    PRINTCHAR ('\n');
    print (obj, printcharfun, 1);
    PRINTCHAR ('\n');
***************
*** 439,444 ****
--- 446,469 ----
    UNGCPRO;
    return obj;
  }
+ 
+ int
+   circular(obj)
+ #ifndef RTPC_REGISTER_BUG
+ register Lisp_Object obj;
+ #else
+ Lisp_Object obj;
+ #endif
+ {
+   int i;
+   for (i = 0; i < circ_depth; i++) {
+     if (EQ(obj,circ_objs[i])) {
+       return(1);
+     }
+   };
+   return(0);
+ }
+ 
  
  static void
  print (obj, printcharfun, escapeflag)
***************
*** 551,561 ****
--- 576,594 ----
  	break;
  
        case Lisp_Cons:
+ 
+ 	if (circular (obj)) {
+ 	  strout(" #1", 3, printcharfun);
+ 	  break;
+ 	}
+ 
  	PRINTCHAR ('(');
  	{
  	  register int i = 0;
  	  register int max = 0;
+ 	  int save_circ_depth = circ_depth;
  
+ 	  circ_objs[circ_depth++] = obj;
  	  if (XTYPE (Vprint_length) == Lisp_Int)
  	    max = XINT (Vprint_length);
  	  while (CONSP (obj))
***************
*** 569,575 ****
--- 602,612 ----
  		}
  	      print (Fcar (obj), printcharfun, escapeflag);
  	      obj = Fcdr (obj);
+ 	      if (circular(obj)) {
+ 		strout (" #1", 3, printcharfun);
+ 		break;
  	      }
+ 	      circ_objs[circ_depth++] = obj;
  	    }
  	  if (!NULL (obj) && !CONSP (obj))
  	    {
***************
*** 576,595 ****
--- 613,646 ----
  	      strout (" . ", 3, printcharfun);
  	      print (obj, printcharfun, escapeflag);
  	    }
+ 	  circ_depth = save_circ_depth;
+ 	}
  	PRINTCHAR (')');
  	break;
  
        case Lisp_Vector:
+ 	if (circular (obj)) {
+ 	  strout(" #1", 3, printcharfun);
+ 	  break;
+ 	}
  	PRINTCHAR ('[');
  	{
  	  register int i;
  	  register Lisp_Object tem;
+ 	  int save_circ_depth = circ_depth;
+ 
+ 	  circ_objs[circ_depth++] = obj;
  	  for (i = 0; i < XVECTOR (obj)->size; i++)
  	    {
  	      if (i) PRINTCHAR (' ');
  	      tem = XVECTOR (obj)->contents[i];
+ 	      if (circular(tem)) {
+ 		strout (" #1", 3, printcharfun);
+ 		break;
+ 	      }
  	      print (tem, printcharfun, escapeflag);
  	    }
+ 	  circ_depth = save_circ_depth;
  	}
  	PRINTCHAR (']');
  	break;



Rowland R Johnson
rowland@vogon.llnl.gov