Guile: Add various fixes allowing the test suite to run.

svn path=/nixpkgs/trunk/; revision=11196

3 files changed, 338 insertions, 6 deletions

diff --git a/pkgs/development/interpreters/guile/default.nix b/pkgs/development/interpreters/guile/default.nix
index 74808b8d9af..bb0a3f35086 100644
--- a/pkgs/development/interpreters/guile/default.nix
+++ b/pkgs/development/interpreters/guile/default.nix
@@ -4,11 +4,13 @@
 stdenv.mkDerivation rec {
   name = "guile-1.8.4";
   src = fetchurl {
-    url = "ftp://ftp.gnu.org/gnu/guile/" + name + ".tar.gz";
+    url = "mirror://gnu/guile/" + name + ".tar.gz";
     sha256 = "1cz1d4n6vzw0lfsvplsiarwqk675f12j596dzfv0h5r9cljpc0ya";
   };
 
-  patches = [ ./test-tmpdir.patch ];
+  patches = [ ./test-tmpdir.patch
+              ./srcprop-no-deadlock.patch
+              ./popen-zombie.patch ];
 
   buildInputs = [ makeWrapper ];
   propagatedBuildInputs = [readline libtool gmp gawk];
@@ -17,10 +19,7 @@ stdenv.mkDerivation rec {
     wrapProgram $out/bin/guile-snarf --prefix PATH : "${gawk}/bin"
   '';
 
-  # FIXME: It seems that we hit a deadlock sometimes when running the
-  # test suite, typically somewhere between `time.test' and
-  # `unit.test'.  To be continued...
-  doCheck = false;
+  doCheck = true;
 
   setupHook = ./setup-hook.sh;
 
diff --git a/pkgs/development/interpreters/guile/popen-zombie.patch b/pkgs/development/interpreters/guile/popen-zombie.patch
new file mode 100644
index 00000000000..215c87a3a7b
--- /dev/null
+++ b/pkgs/development/interpreters/guile/popen-zombie.patch
@@ -0,0 +1,45 @@
+Index: guile/test-suite/tests/popen.test
+===================================================================
+RCS file: /sources/guile/guile/guile-core/guile/test-suite/tests/popen.test,v
+retrieving revision 1.3.2.2
+diff -u -r1.3.2.2 popen.test
+--- guile/test-suite/tests/popen.test	25 Aug 2006 01:21:39 -0000	1.3.2.2
++++ guile/test-suite/tests/popen.test	18 Mar 2008 20:18:08 -0000
+@@ -1,6 +1,6 @@
+ ;;;; popen.test --- exercise ice-9/popen.scm      -*- scheme -*-
+ ;;;;
+-;;;; Copyright 2003, 2006 Free Software Foundation, Inc.
++;;;; Copyright 2003, 2006, 2008 Free Software Foundation, Inc.
+ ;;;;
+ ;;;; This library is free software; you can redistribute it and/or
+ ;;;; modify it under the terms of the GNU Lesser General Public
+@@ -81,12 +81,15 @@
+     (let* ((pair (pipe))
+ 	   (port (with-error-to-port (cdr pair)
+ 		   (lambda ()
+-		     (open-input-pipe
+-		      "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999")))))
++		     (open-input-output-pipe
++		      "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read")))))
+       (close-port (cdr pair))   ;; write side
+-      (and (char? (read-char (car pair))) ;; wait for child to do its thing
+-	   (char-ready? port)
+-	   (eof-object? (read-char port))))))
++      (let ((result (and (char? (read-char (car pair))) ;; wait for child to do its thing
++			 (char-ready? port)
++			 (eof-object? (read-char port)))))
++	(display "hello!\n" port)
++	(close-pipe port)
++	result))))
+ 
+ ;;
+ ;; open-output-pipe
+@@ -132,7 +135,7 @@
+ 	      (port (with-error-to-port (cdr pair)
+ 		      (lambda ()
+ 			(open-output-pipe
+-			 "exec 0</dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999")))))
++			 "exec 0</dev/null; echo closed 1>&2; exec 2>/dev/null; read")))))
+ 	 (close-port (cdr pair))   ;; write side
+ 	 (and (char? (read-char (car pair))) ;; wait for child to do its thing
+ 	      (catch 'system-error
diff --git a/pkgs/development/interpreters/guile/srcprop-no-deadlock.patch b/pkgs/development/interpreters/guile/srcprop-no-deadlock.patch
new file mode 100644
index 00000000000..26d10e07d17
--- /dev/null
+++ b/pkgs/development/interpreters/guile/srcprop-no-deadlock.patch
@@ -0,0 +1,288 @@
+Index: guile/libguile/eval.c
+===================================================================
+RCS file: /sources/guile/guile/guile-core/guile/libguile/eval.c,v
+retrieving revision 1.405.2.13
+diff -u -r1.405.2.13 eval.c
+--- guile/libguile/eval.c	10 Mar 2008 22:13:33 -0000	1.405.2.13
++++ guile/libguile/eval.c	13 Mar 2008 22:42:30 -0000
+@@ -3039,7 +3039,7 @@
+ do { \
+   SCM_SET_ARGSREADY (debug);\
+   if (scm_check_apply_p && SCM_TRAPS_P)\
+-    if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
++    if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
+       {\
+ 	SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
+ 	SCM_SET_TRACED_FRAME (debug); \
+Index: guile/libguile/srcprop.c
+===================================================================
+RCS file: /sources/guile/guile/guile-core/guile/libguile/srcprop.c,v
+retrieving revision 1.73.2.1
+diff -u -r1.73.2.1 srcprop.c
+--- guile/libguile/srcprop.c	12 Feb 2006 13:42:51 -0000	1.73.2.1
++++ guile/libguile/srcprop.c	13 Mar 2008 22:42:30 -0000
+@@ -37,7 +37,7 @@
+ /* {Source Properties}
+  *
+  * Properties of source list expressions.
+- * Five of these have special meaning and optimized storage:
++ * Five of these have special meaning:
+  *
+  * filename    string   The name of the source file.
+  * copy        list     A copy of the list expression.
+@@ -55,29 +55,47 @@
+ SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
+ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
+ 
+-scm_t_bits scm_tc16_srcprops;
+-static scm_t_srcprops_chunk *srcprops_chunklist = 0;
+-static scm_t_srcprops *srcprops_freelist = 0;
+ 
+ 
++/*
++ *  Source properties are stored as double cells with the
++ *  following layout:
++  
++ * car = tag
++ * cbr = pos
++ * ccr = copy
++ * cdr = plist 
++ */
++
++#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
++#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
++#define SRCPROPPOS(p) (SCM_CELL_WORD(p,1))
++#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
++#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
++#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
++#define SRCPROPPLIST(p) (SCM_CELL_OBJECT_3(p))
++#define SETSRCPROPBRK(p) \
++ (SCM_SET_SMOB_FLAGS ((p), \
++                      SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
++#define CLEARSRCPROPBRK(p)  \
++ (SCM_SET_SMOB_FLAGS ((p), \
++                      SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
++#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
++#define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c)))
++#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
++#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
++
++
++
++scm_t_bits scm_tc16_srcprops;
++
+ static SCM
+ srcprops_mark (SCM obj)
+ {
+-  scm_gc_mark (SRCPROPFNAME (obj));
+   scm_gc_mark (SRCPROPCOPY (obj));
+   return SRCPROPPLIST (obj);
+ }
+ 
+-
+-static size_t
+-srcprops_free (SCM obj)
+-{
+-  *((scm_t_srcprops **) SCM_SMOB_DATA (obj)) = srcprops_freelist;
+-  srcprops_freelist = (scm_t_srcprops *) SCM_SMOB_DATA (obj);
+-  return 0; /* srcprops_chunks are not freed until leaving guile */
+-}
+-
+-
+ static int
+ srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
+ {
+@@ -99,38 +117,45 @@
+ }
+ 
+ 
++/*
++ * We remember the last file name settings, so we can share that plist
++ * entry.  This works because scm_set_source_property_x does not use
++ * assoc-set! for modifying the plist.
++ *
++ * This variable contains a protected cons, whose cdr is the cached
++ * plist
++ */
++static SCM scm_last_plist_filename;
++
+ SCM
+ scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist)
+ {
+-  register scm_t_srcprops *ptr;
+-  SCM_CRITICAL_SECTION_START;
+-  if ((ptr = srcprops_freelist) != NULL)
+-    srcprops_freelist = *(scm_t_srcprops **)ptr;
+-  else
++  if (!SCM_UNBNDP (filename))
+     {
+-      size_t i;
+-      scm_t_srcprops_chunk *mem;
+-      size_t n = sizeof (scm_t_srcprops_chunk)
+-	            + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
+-      SCM_SYSCALL (mem = (scm_t_srcprops_chunk *) scm_malloc (n));
+-      if (mem == NULL)
+-	scm_memory_error ("srcprops");
+-      scm_gc_register_collectable_memory (mem, n, "srcprops");
+-      
+-      mem->next = srcprops_chunklist;
+-      srcprops_chunklist = mem;
+-      ptr = &mem->srcprops[0];
+-      for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
+-	*(scm_t_srcprops **)&ptr[i] = &ptr[i + 1];
+-      *(scm_t_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
+-      srcprops_freelist = (scm_t_srcprops *) &ptr[1];
++      SCM old_plist = plist;
++
++      /*
++	have to extract the acons, and operate on that, for
++	thread safety.
++       */
++      SCM last_acons = SCM_CDR (scm_last_plist_filename);
++      if (old_plist == SCM_EOL
++	  && SCM_CDAR (last_acons) == filename)
++	{
++	  plist = last_acons;
++	}
++      else
++	{
++	  plist = scm_acons (scm_sym_filename, filename, plist);
++	  if (old_plist == SCM_EOL)
++	    SCM_SETCDR (scm_last_plist_filename, plist);
++	}
+     }
+-  ptr->pos = SRCPROPMAKPOS (line, col);
+-  ptr->fname = filename;
+-  ptr->copy = copy;
+-  ptr->plist = plist;
+-  SCM_CRITICAL_SECTION_END;
+-  SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
++  
++  SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
++		       SRCPROPMAKPOS (line, col),
++		       copy,
++		       plist);
+ }
+ 
+ 
+@@ -140,8 +165,6 @@
+   SCM plist = SRCPROPPLIST (obj);
+   if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
+     plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist);
+-  if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
+-    plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist);
+   plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist);
+   plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist);
+   plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist);
+@@ -206,7 +229,6 @@
+   if      (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p));
+   else if (scm_is_eq (scm_sym_line,       key)) p = scm_from_int (SRCPROPLINE (p));
+   else if (scm_is_eq (scm_sym_column,     key)) p = scm_from_int (SRCPROPCOL (p));
+-  else if (scm_is_eq (scm_sym_filename,   key)) p = SRCPROPFNAME (p);
+   else if (scm_is_eq (scm_sym_copy,       key)) p = SRCPROPCOPY (p);
+   else
+     {
+@@ -277,13 +299,6 @@
+ 		      scm_make_srcprops (0, scm_to_int (datum),
+ 					 SCM_UNDEFINED, SCM_UNDEFINED, p));
+     }
+-  else if (scm_is_eq (scm_sym_filename, key))
+-    {
+-      if (SRCPROPSP (p))
+-	SRCPROPFNAME (p) = datum;
+-      else
+-	SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
+-    }
+   else if (scm_is_eq (scm_sym_copy, key))
+     {
+       if (SRCPROPSP (p))
+@@ -308,29 +323,18 @@
+ {
+   scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
+   scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark);
+-  scm_set_smob_free (scm_tc16_srcprops, srcprops_free);
+   scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
+ 
+   scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
+   scm_c_define ("source-whash", scm_source_whash);
+ 
++  scm_last_plist_filename
++    = scm_permanent_object (scm_cons (SCM_EOL,
++				      scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)));
++
+ #include "libguile/srcprop.x"
+ }
+ 
+-void
+-scm_finish_srcprop ()
+-{
+-  register scm_t_srcprops_chunk *ptr = srcprops_chunklist, *next;
+-  size_t n= sizeof (scm_t_srcprops_chunk)
+-    + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
+-  while (ptr)
+-    {
+-      next = ptr->next;
+-      scm_gc_unregister_collectable_memory (ptr, n, "srcprops");
+-      free ((char *) ptr);
+-      ptr = next;
+-    }
+-}
+ 
+ /*
+   Local Variables:
+Index: guile/libguile/srcprop.h
+===================================================================
+RCS file: /sources/guile/guile/guile-core/guile/libguile/srcprop.h,v
+retrieving revision 1.36.2.1
+diff -u -r1.36.2.1 srcprop.h
+--- guile/libguile/srcprop.h	12 Feb 2006 13:42:51 -0000	1.36.2.1
++++ guile/libguile/srcprop.h	13 Mar 2008 22:42:30 -0000
+@@ -49,46 +49,10 @@
+ 
+ /* {Source properties}
+  */
+-
+-SCM_API scm_t_bits scm_tc16_srcprops;
+-
+-typedef struct scm_t_srcprops
+-{
+-  unsigned long pos;
+-  SCM fname;
+-  SCM copy;
+-  SCM plist;
+-} scm_t_srcprops;
+-
+-#define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */
+-typedef struct scm_t_srcprops_chunk
+-{
+-  struct scm_t_srcprops_chunk *next;
+-  scm_t_srcprops srcprops[1];
+-} scm_t_srcprops_chunk;
+-
++#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
+ #define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
+ 
+-#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
+-#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
+-#define SRCPROPPOS(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->pos
+-#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
+-#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
+-#define SRCPROPFNAME(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->fname
+-#define SRCPROPCOPY(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->copy
+-#define SRCPROPPLIST(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->plist
+-#define SETSRCPROPBRK(p) \
+- (SCM_SET_SMOB_FLAGS ((p), \
+-                      SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
+-#define CLEARSRCPROPBRK(p)  \
+- (SCM_SET_SMOB_FLAGS ((p), \
+-                      SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
+-#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
+-#define SETSRCPROPPOS(p, l, c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c))
+-#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
+-#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
+-
+-#define PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
++SCM_API scm_t_bits scm_tc16_srcprops;
+ 
+ SCM_API SCM scm_sym_filename;
+ SCM_API SCM scm_sym_copy;