This is the mail archive of the guile@sourceware.cygnus.com mailing list for the Guile project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]

Patch for append!


On 20 Jan 2000, Mikael Djurfeldt wrote:

> Dirk Herrmann <dirk@ida.ing.tu-bs.de> writes:
> 
> > ---------------------
> > guile> (define foo (cons 1 2))
> > guile> (append! foo (list 3))
> > (1 3)
> > ---------------------
> > 
> > Is this inconsistency OK?
> 
> Nope.  This is a bug.


Then we need a fix, right? :-)

Below it is.  Unfortunately, since some other patches I sent have not been
applied yet, I have to send you the complete diff of my local list.c
against the current CVS.


The interesting part (i.e. the part related to the bug) starts at the
definition of scm_ilast_pair.

* extracted the functionality of scm_last_pair into the static function
  scm_ilast_pair to allow more flexible error reporting for calling
  functions.
* scm_append_x and scm_last_pair make use of scm_ilast_pair
* scm_append_x now handles improper lists appropriately.


Here's a small set of tests that you can cut and paste to verify the
patches please you.

(define foo (list 1 2))
(set-cdr! (cdr foo) (cdr foo))
(define bar (cons 3 4))
(define baz (list 5 6 7))
(append!)
(append! '())
(append! '() '())
(append! '() foo)
(append! '() foo '())
(append! (list 0) foo)
(append! (list 0) foo '())
(append! '() bar)
(append! '() bar '())
(append! (list 0) bar)
(append! (list 0) bar '())
(append! '() baz)
(append! '() baz '())
(append! (list 0) baz)
(append! (list 0) baz '())
(append! baz baz)



Best regards
Dirk Herrmann



Index: libguile/list.c
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/list.c,v
retrieving revision 1.28
diff -u -p -r1.28 list.c
--- list.c	2000/01/18 13:09:54	1.28
+++ list.c	2000/01/20 19:55:45
@@ -61,17 +61,14 @@
 
 /* creating lists */
 
-/* SCM_P won't help us deal with varargs here.  */
 SCM
 scm_listify (SCM elt, ...)
 {
   va_list foo;
-  SCM answer;
-  SCM *pos;
+  SCM answer = SCM_EOL;
+  SCM *pos = &answer;
 
   var_start (foo, elt);
-  answer = SCM_EOL;
-  pos = &answer;
   while (elt != SCM_UNDEFINED)
     {
       *pos = scm_cons (elt, SCM_EOL);
@@ -94,7 +91,7 @@ SCM_DEFINE (scm_list, "list", 0, 0, 1, 
 
 SCM_DEFINE (scm_list_star, "list*", 1, 0, 1, 
             (SCM arg, SCM rest),
-"")
+	    "Return an improper list of the arguments.")
 #define FUNC_NAME s_scm_list_star
 {
   if (SCM_NNULLP (rest))
@@ -120,16 +117,17 @@ SCM_DEFINE (scm_null_p, "null?", 1, 0, 0
 "")
 #define FUNC_NAME s_scm_null_p
 {
-  return SCM_BOOL(SCM_NULLP(x));
+  return SCM_BOOL (SCM_NULLP (x));
 }
 #undef FUNC_NAME
 
+
 SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, 
            (SCM x),
 "")
 #define FUNC_NAME s_scm_list_p
 {
-  return SCM_BOOL(scm_ilength(x)>=0);
+  return SCM_BOOL (scm_ilength (x) >= 0);
 }
 #undef FUNC_NAME
 
@@ -164,6 +162,7 @@ scm_ilength(SCM sx)
   return -1;
 }
 
+
 SCM_DEFINE (scm_length, "length", 1, 0, 0, 
            (SCM lst),
 "")
@@ -181,44 +180,89 @@ SCM_DEFINE (scm_length, "length", 1, 0, 
 
 SCM_DEFINE (scm_append, "append", 0, 0, 1, 
             (SCM args),
-	    "A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,\n"
-	    "The Revised^4 Report on Scheme}).  The cdr field of each list's final\n"
-	    "pair is changed to point to the head of the next list, so no consing is\n"
-	    "performed.  Return a pointer to the mutated list.")
+	    "")
 #define FUNC_NAME s_scm_append
 {
+  SCM arg = SCM_EOL;
   SCM res = SCM_EOL;
-  SCM *lloc = &res, arg;
-  if (SCM_IMP(args)) {
-    SCM_VALIDATE_NULL (SCM_ARGn, args);
-    return res;
-  }
-  SCM_VALIDATE_CONS (SCM_ARGn, args);
-  while (1) {
-    arg = SCM_CAR(args);
-    args = SCM_CDR(args);
-    if (SCM_IMP(args)) {
-      *lloc = arg;
-      SCM_VALIDATE_NULL (SCM_ARGn, args);
-      return res;
-    }
-    SCM_VALIDATE_CONS (SCM_ARGn, args);
-    for (; SCM_CONSP(arg); arg = SCM_CDR(arg)) {
-      *lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
-      lloc = SCM_CDRLOC(*lloc);
+  SCM *lloc = &res;
+
+  while (SCM_NNULLP (args)) 
+    {
+      arg = SCM_CAR (args);
+      args = SCM_CDR (args);
+      if (SCM_NNULLP (args)) 
+	{
+	  /* arg is not the last argument, thus it has to be copied */
+
+	  SCM tortoise = arg;
+	  SCM hare = arg;
+	  while (SCM_CONSP (hare))
+	    {
+	      *lloc = scm_cons(SCM_CAR (hare), SCM_EOL);
+	      lloc = SCM_CDRLOC (*lloc);
+	      hare = SCM_CDR (hare);
+	      if (SCM_CONSP (hare))
+		{
+		  *lloc = scm_cons(SCM_CAR (hare), SCM_EOL);
+		  lloc = SCM_CDRLOC (*lloc);
+		  hare = SCM_CDR (hare);
+
+		  tortoise = SCM_CDR (tortoise);
+		  if (hare == tortoise)
+		    {
+		      SCM_MISC_ERROR ("Circular structure: ~S", SCM_LIST1 (arg));
+		    }
+		}
+	    }
+	  SCM_VALIDATE_NULL (SCM_ARGn, hare);
+	}
     }
-    SCM_VALIDATE_NULL (SCM_ARGn, arg);
-  }
+  *lloc = arg;
+  return res;
 }
 #undef FUNC_NAME
 
 
+/* Return a pointer to the last pair in @var{lst}.  If @var{lst} does not
+   consist of at least one pair or is circular, SCM_UNDEFINED is returned. */
+static SCM
+scm_ilast_pair(SCM lst)
+{
+  if (SCM_CONSP(lst))
+    {
+      SCM tortoise = lst;
+      SCM hare = lst;
+
+      do {
+	SCM ahead = SCM_CDR(hare);
+	if (SCM_NCONSP(ahead)) return hare;
+	hare = ahead;
+	ahead = SCM_CDR(hare);
+	if (SCM_NCONSP(ahead)) return hare;
+	hare = ahead;
+	tortoise = SCM_CDR(tortoise);
+      }
+      while (hare != tortoise);
+      return SCM_UNDEFINED;
+    }
+  else
+    {
+      return SCM_UNDEFINED;
+    }
+}
+
+
 SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, 
             (SCM args),
-"")
+	    "A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,\n"
+	    "The Revised^4 Report on Scheme}).  The cdr field of each list's final\n"
+	    "pair is changed to point to the head of the next list, so no consing is\n"
+	    "performed.  Return a pointer to the mutated list.")
 #define FUNC_NAME s_scm_append_x
 {
   SCM arg;
+  SCM last_pair;
  tail:
   if (SCM_NULLP(args)) return SCM_EOL;
   arg = SCM_CAR(args);
@@ -226,7 +270,16 @@ SCM_DEFINE (scm_append_x, "append!", 0, 
   if (SCM_NULLP(args)) return arg;
   if (SCM_NULLP(arg)) goto tail;
   SCM_VALIDATE_CONS (SCM_ARG1,arg);
-  SCM_SETCDR (scm_last_pair (arg), scm_append_x (args));
+  last_pair = scm_ilast_pair (arg);
+  if (last_pair != SCM_UNDEFINED)
+    {
+      SCM_ASSERT (SCM_NULLP (SCM_CDR (last_pair)), arg, SCM_ARGn, FUNC_NAME);
+      SCM_SETCDR (last_pair, scm_append_x (args));
+    }
+  else
+    {
+      SCM_MISC_ERROR ("Circular structure: ~S", SCM_LIST1 (arg));
+    }
   return arg;
 }
 #undef FUNC_NAME
@@ -238,24 +291,14 @@ SCM_DEFINE (scm_last_pair, "last-pair", 
 	    "@var{lst} is circular.")
 #define FUNC_NAME s_scm_last_pair
 {
-  SCM tortoise = lst;
-  SCM hare = lst;
-
-  if (SCM_NULLP (lst))
-    return SCM_EOL;
+  SCM last_pair;
 
   SCM_VALIDATE_CONS (SCM_ARG1, lst);
-  do {
-    SCM ahead = SCM_CDR(hare);
-    if (SCM_NCONSP(ahead)) return hare;
-    hare = ahead;
-    ahead = SCM_CDR(hare);
-    if (SCM_NCONSP(ahead)) return hare;
-    hare = ahead;
-    tortoise = SCM_CDR(tortoise);
-  }
-  while (hare != tortoise);
-  SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst));
+  last_pair = scm_ilast_pair(lst);
+  if (last_pair != SCM_UNDEFINED) 
+    return last_pair;
+  else
+    SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst));
 }
 #undef FUNC_NAME
 



Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]