Merge remote-tracking branch 'origin/stable-2.0'

Conflicts:
	libguile/procprop.c

doc/ref/api-debug.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -645,10 +645,13 @@ using @code{debug-set!}.
 
 @deffn {Scheme Procedure} debug-enable option-name
 @deffnx {Scheme Procedure} debug-disable option-name
-@deffnx {Scheme Procedure} debug-set! option-name value
+@deffnx {Scheme Syntax} debug-set! option-name value
 Modify the debug options.  @code{debug-enable} should be used with boolean
 options and switches them on, @code{debug-disable} switches them off.
-@code{debug-set!} can be used to set an option to a specific value.
+
+@code{debug-set!} can be used to set an option to a specific value.  Due
+to historical oddities, it is a macro that expects an unquoted option
+name.
 @end deffn
 
 @subsubheading Stack overflow

doc/ref/api-evaluation.texi

@@ -341,10 +341,13 @@ using @code{read-set!}.
 
 @deffn {Scheme Procedure} read-enable option-name
 @deffnx {Scheme Procedure} read-disable option-name
-@deffnx {Scheme Procedure} read-set! option-name value
+@deffnx {Scheme Syntax} read-set! option-name value
 Modify the read options.  @code{read-enable} should be used with boolean
 options and switches them on, @code{read-disable} switches them off.
-@code{read-set!} can be used to set an option to a specific value.
+
+@code{read-set!} can be used to set an option to a specific value.  Due
+to historical oddities, it is a macro that expects an unquoted option
+name.
 @end deffn
 
 For example, to make @code{read} fold all symbols to their lower case
@@ -416,10 +419,11 @@ quote-keywordish-symbols  reader  How to print symbols that have a colon
                                   not '#f'.
 @end smalllisp
 
-These options may be modified with the print-set! procedure.
+These options may be modified with the print-set! syntax.
 
-@deffn {Scheme Procedure} print-set! option-name value
+@deffn {Scheme Syntax} print-set! option-name value
-Modify the print options.
+Modify the print options.  Due to historical oddities, @code{print-set!}
+is a macro that expects an unquoted option name.
 @end deffn
 
 

doc/ref/api-io.texi

@@ -336,14 +336,6 @@ If @var{pstate} isn't supplied and @var{port} already has
 a print state, the old print state is reused.
 @end deffn
 
-@deffn {Scheme Procedure} print-options-interface [setting]
-@deffnx {C Function} scm_print_options (setting)
-Option interface for the print options. Instead of using
-this procedure directly, use the procedures
-@code{print-enable}, @code{print-disable}, @code{print-set!}
-and @code{print-options}.
-@end deffn
-
 @deffn {Scheme Procedure} simple-format destination message . args
 @deffnx {C Function} scm_simple_format (destination, message, args)
 Write @var{message} to @var{destination}, defaulting to

doc/ref/repl-modules.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -84,18 +84,21 @@ $endif
 @node Readline Options
 @subsection Readline Options
 
-@c FIXME::martin: Review me!
-
 @cindex readline options
-The readline interface module can be configured in several ways to
+The readline interface module can be tweaked in a few ways to better
-better suit the user's needs.  Configuration is done via the readline
+suit the user's needs.  Configuration is done via the readline module's
-module's options interface, in a similar way to the evaluator and
+options interface, in a similar way to the evaluator and debugging
-debugging options (@pxref{Runtime Options}).
+options (@pxref{Runtime Options}).
+
+@deffn {Scheme Procedure} readline-options
+@deffnx {Scheme Procedure} readline-enable option-name
+@deffnx {Scheme Procedure} readline-disable option-name
+@deffnx {Scheme Syntax} readline-set! option-name value
+Accessors for the readline options.  Note that unlike the enable/disable
+procedures, @code{readline-set!} is syntax, which expects an unquoted
+option name.
+@end deffn
 
-@findex readline-options
-@findex readline-enable
-@findex readline-disable
-@findex readline-set!
 Here is the list of readline options generated by typing
 @code{(readline-options 'help)} in Guile.  You can also see the
 default values.
@@ -107,15 +110,6 @@ bounce-parens   500     Time (ms) to show matching opening parenthesis
                         (0 = off).
 @end smalllisp
 
-The history length specifies how many input lines will be remembered.
-If the history contains that many lines and additional lines are
-entered, the oldest lines will be lost.  You can switch on/off the
-usage of the history file using the following call.
-
-@lisp
-(readline-disable 'history)
-@end lisp
-
 The readline options interface can only be used @emph{after} loading
 the readline module, because it is defined in that module.
 

libguile/Makefile.am

@@ -52,12 +52,17 @@ noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig
 
 gen_scmconfig_SOURCES = gen-scmconfig.c
 
-## Override default rule; this should be compiled for BUILD host.
+## Override default rule; this should be compiled for BUILD host.  Note
-## For some reason, OBJEXT does not include the dot
+## that we don't add $(AM_CPPFLAGS) here, as we need to run this
+## program, but $(top_srcdir)/lib has a gnulib configured for the
+## target.  Instead we manually add $(top_builddir), in order to pick up
+## the generated config.h and gen-scmconfig.h.  Nothing else from Guile
+## is included by this code generator.
 gen-scmconfig.$(OBJEXT): gen-scmconfig.c
 	$(AM_V_GEN) \
 	if [ "$(cross_compiling)" = "yes" ]; then \
-		$(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) $(AM_CPPFLAGS) -c -o $@ $<; \
+		$(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) -I$(top_builddir) \
+	           -c -o $@ $<; \
 	else \
 		$(COMPILE) -c -o $@ $<; \
 	fi

libguile/filesys.c

@@ -473,7 +473,7 @@ static int fstat_Win32 (int fdes, struct stat *buf)
   /* Is this a socket ? */
   if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
     {
-      buf->st_mode = _S_IFSOCK | _S_IREAD | _S_IWRITE | _S_IEXEC;
+      buf->st_mode = _S_IREAD | _S_IWRITE | _S_IEXEC;
       buf->st_nlink = 1;
       buf->st_atime = buf->st_ctime = buf->st_mtime = time (NULL);
       return 0;

libguile/goops.c

@@ -170,6 +170,7 @@ static SCM class_bytevector;
 static SCM class_uvec;
 
 static SCM vtable_class_map = SCM_BOOL_F;
+static scm_i_pthread_mutex_t vtable_class_map_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 /* Port classes.  Allocate 3 times the maximum number of port types so that
    input ports, output ports, and in/out ports can be stored at different
@@ -197,6 +198,8 @@ scm_i_define_class_for_vtable (SCM vtable)
 {
   SCM class;
 
+  scm_i_pthread_mutex_lock (&vtable_class_map_lock);
+
   if (scm_is_false (vtable_class_map))
     vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
   
@@ -205,6 +208,8 @@ scm_i_define_class_for_vtable (SCM vtable)
 
   class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F);
   
+  scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
+
   if (scm_is_false (class))
     {
       if (SCM_UNPACK (scm_class_class))
@@ -220,7 +225,11 @@ scm_i_define_class_for_vtable (SCM vtable)
         /* `create_struct_classes' will fill this in later.  */
         class = SCM_BOOL_F;
 
+      /* Don't worry about races.  This only happens when creating a
+         vtable, which happens by definition in one thread.  */
+      scm_i_pthread_mutex_lock (&vtable_class_map_lock);
       scm_hashq_set_x (vtable_class_map, vtable, class);
+      scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
     }
 
   return class;
@@ -2671,6 +2680,7 @@ make_struct_class (void *closure SCM_UNUSED,
 static void
 create_struct_classes (void)
 {
+  /* FIXME: take the vtable_class_map while initializing goops?  */
   scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
                           vtable_class_map);
 }

libguile/procprop.c

@@ -156,9 +156,15 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 
   SCM_VALIDATE_PROC (1, proc);
 
-  props = scm_procedure_properties (proc);
-
   scm_i_pthread_mutex_lock (&overrides_lock);
+  props = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
+  if (scm_is_false (props))
+    {
+      if (SCM_PROGRAM_P (proc))
+        props = scm_i_program_properties (proc);
+      else
+        props = SCM_EOL;
+    }
   scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val));
   scm_i_pthread_mutex_unlock (&overrides_lock);
 

libguile/read.c

@@ -357,24 +357,20 @@ flush_ws (SCM port, const char *eoferr)
 
 static SCM scm_read_expression (SCM port);
 static SCM scm_read_sharp (int chr, SCM port);
-static SCM recsexpr (SCM obj, long line, int column, SCM filename);
 
 
 static SCM
 scm_read_sexp (scm_t_wchar chr, SCM port)
 #define FUNC_NAME "scm_i_lreadparen"
 {
-  register int c;
+  int c;
-  register SCM tmp;
+  SCM tmp, tl, ans = SCM_EOL;
-  register SCM tl, ans = SCM_EOL;
-  SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
   const int terminating_char = ((chr == '[') ? ']' : ')');
 
   /* Need to capture line and column numbers here. */
   long line = SCM_LINUM (port);
   int column = SCM_COL (port) - 1;
 
-
   c = flush_ws (port, FUNC_NAME);
   if (terminating_char == c)
     return SCM_EOL;
@@ -393,12 +389,6 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
   /* Build the head of the list structure. */
   ans = tl = scm_cons (tmp, SCM_EOL);
 
-  if (SCM_COPY_SOURCE_P)
-    ans2 = tl2 = scm_cons (scm_is_pair (tmp)
-			   ? copy
-			   : tmp,
-			   SCM_EOL);
-
   while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
     {
       SCM new_tail;
@@ -415,10 +405,6 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
 	{
 	  SCM_SETCDR (tl, tmp = scm_read_expression (port));
 
-	  if (SCM_COPY_SOURCE_P)
-	    SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp,
-				       SCM_EOL));
-
 	  c = flush_ws (port, FUNC_NAME);
 	  if (terminating_char != c)
 	    scm_i_input_error (FUNC_NAME, port,
@@ -429,27 +415,12 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
       new_tail = scm_cons (tmp, SCM_EOL);
       SCM_SETCDR (tl, new_tail);
       tl = new_tail;
-
-      if (SCM_COPY_SOURCE_P)
-	{
-	  SCM new_tail2 = scm_cons (scm_is_pair (tmp)
-				    ? copy
-				    : tmp, SCM_EOL);
-	  SCM_SETCDR (tl2, new_tail2);
-	  tl2 = new_tail2;
-	}
     }
 
  exit:
   if (SCM_RECORD_POSITIONS_P)
-    scm_hashq_set_x (scm_source_whash,
+    scm_i_set_source_properties_x (ans, line, column, SCM_FILENAME (port));
-                     ans,
+
-                     scm_make_srcprops (line, column,
-                                        SCM_FILENAME (port),
-                                        SCM_COPY_SOURCE_P
-                                        ? ans2
-                                        : SCM_UNDEFINED,
-                                        SCM_EOL));
   return ans;
 }
 #undef FUNC_NAME
@@ -805,16 +776,7 @@ scm_read_quote (int chr, SCM port)
 
   p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
   if (SCM_RECORD_POSITIONS_P)
-    scm_hashq_set_x (scm_source_whash, p,
+    scm_i_set_source_properties_x (p, line, column, SCM_FILENAME (port));
-                     scm_make_srcprops (line, column,
-                                        SCM_FILENAME (port),
-                                        SCM_COPY_SOURCE_P
-                                        ? (scm_cons2 (SCM_CAR (p),
-                                                      SCM_CAR (SCM_CDR (p)),
-                                                      SCM_EOL))
-                                        : SCM_UNDEFINED,
-                                        SCM_EOL));
-
 
   return p;
 }
@@ -864,16 +826,7 @@ scm_read_syntax (int chr, SCM port)
 
   p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
   if (SCM_RECORD_POSITIONS_P)
-    scm_hashq_set_x (scm_source_whash, p,
+    scm_i_set_source_properties_x (p, line, column, SCM_FILENAME (port));
-                     scm_make_srcprops (line, column,
-                                        SCM_FILENAME (port),
-                                        SCM_COPY_SOURCE_P
-                                        ? (scm_cons2 (SCM_CAR (p),
-                                                      SCM_CAR (SCM_CDR (p)),
-                                                      SCM_EOL))
-                                        : SCM_UNDEFINED,
-                                        SCM_EOL));
-
 
   return p;
 }
@@ -1332,15 +1285,12 @@ scm_read_sharp_extension (int chr, SCM port)
       SCM got;
 
       got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
-      if (!scm_is_eq (got, SCM_UNSPECIFIED))
+
-	{
+      if (scm_is_pair (got) && !scm_i_has_source_properties (got))
-	  if (SCM_RECORD_POSITIONS_P)
+        scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port));
-	    return (recsexpr (got, line, column,
+      
-			      SCM_FILENAME (port)));
-	  else
       return got;
     }
-    }
 
   return SCM_UNSPECIFIED;
 }
@@ -1531,53 +1481,6 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0,
 
 
 
-/* Used when recording expressions constructed by `scm_read_sharp ()'.  */
-static SCM
-recsexpr (SCM obj, long line, int column, SCM filename)
-{
-  if (!scm_is_pair(obj)) {
-    return obj;
-  } else {
-    SCM tmp, copy;
-    /* If this sexpr is visible in the read:sharp source, we want to
-       keep that information, so only record non-constant cons cells
-       which haven't previously been read by the reader. */
-    if (scm_is_false (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F)))
-      {
-	if (SCM_COPY_SOURCE_P)
-	  {
-	    copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
-			     SCM_UNDEFINED);
-	    for (tmp = obj; scm_is_pair (tmp); tmp = SCM_CDR (tmp))
-	      {
-		SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
-						      line,
-						      column,
-						      filename),
-					    SCM_UNDEFINED));
-		copy = SCM_CDR (copy);
-	      }
-	    SCM_SETCDR (copy, tmp);
-	  }
-	else
-	  {
-	    recsexpr (SCM_CAR (obj), line, column, filename);
-	    for (tmp = obj; scm_is_pair (tmp); tmp = SCM_CDR (tmp))
-	      recsexpr (SCM_CAR (tmp), line, column, filename);
-	    copy = SCM_UNDEFINED;
-	  }
-	scm_hashq_set_x (scm_source_whash,
-                         obj,
-                         scm_make_srcprops (line,
-                                            column,
-                                            filename,
-                                            copy,
-                                            SCM_EOL));
-      }
-    return obj;
-  }
-}
-
 /* Manipulate the read-hash-procedures alist.  This could be written in
    Scheme, but maybe it will also be used by C code during initialisation.  */
 SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,

libguile/smob.c

@@ -418,12 +418,16 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
 }
 
 static SCM tramp_weak_map = SCM_BOOL_F;
+static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
 SCM
 scm_i_smob_apply_trampoline (SCM smob)
 {
-  /* could use hashq-create-handle!, but i don't know what to do if it returns a
+  SCM tramp;
-     weak pair */
+
-  SCM tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
+  scm_i_pthread_mutex_lock (&tramp_lock);
+  tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
+  scm_i_pthread_mutex_unlock (&tramp_lock);
 
   if (scm_is_true (tramp))
     return tramp;
@@ -440,7 +444,12 @@ scm_i_smob_apply_trampoline (SCM smob)
       SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
       tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
                                 objtable, SCM_BOOL_F);
+
+      /* Race conditions (between the ref and this set!) cannot cause
+         any harm here.  */
+      scm_i_pthread_mutex_lock (&tramp_lock);
       scm_hashq_set_x (tramp_weak_map, smob, tramp);
+      scm_i_pthread_mutex_unlock (&tramp_lock);
       return tramp;
     }
 }

libguile/srcprop.c

@@ -38,6 +38,8 @@
 
 #include "libguile/validate.h"
 #include "libguile/srcprop.h"
+#include "libguile/private-options.h"
+
 
 /* {Source Properties}
  *
@@ -57,8 +59,9 @@ SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename");
 SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
 SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
 SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
-SCM scm_source_whash;
 
+static SCM scm_source_whash;
+static scm_i_pthread_mutex_t source_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 
 /*
@@ -163,7 +166,11 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
 {
   SCM p;
   SCM_VALIDATE_NIM (1, obj);
+
+  scm_i_pthread_mutex_lock (&source_lock);
   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); 
+  scm_i_pthread_mutex_unlock (&source_lock);
+
   if (SRCPROPSP (p))
     return scm_srcprops_to_alist (p);
   else
@@ -181,11 +188,49 @@ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
 #define FUNC_NAME s_scm_set_source_properties_x
 {
   SCM_VALIDATE_NIM (1, obj);
+
+  scm_i_pthread_mutex_lock (&source_lock);
   scm_hashq_set_x (scm_source_whash, obj, alist);
+  scm_i_pthread_mutex_unlock (&source_lock);
+
   return alist;
 }
 #undef FUNC_NAME
 
+int
+scm_i_has_source_properties (SCM obj)
+#define FUNC_NAME "%set-source-properties"
+{
+  int ret;
+  
+  SCM_VALIDATE_NIM (1, obj);
+
+  scm_i_pthread_mutex_lock (&source_lock);
+  ret = scm_is_true (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F));
+  scm_i_pthread_mutex_unlock (&source_lock);
+
+  return ret;
+}
+#undef FUNC_NAME
+  
+
+void
+scm_i_set_source_properties_x (SCM obj, long line, int col, SCM fname)
+#define FUNC_NAME "%set-source-properties"
+{
+  SCM_VALIDATE_NIM (1, obj);
+
+  scm_i_pthread_mutex_lock (&source_lock);
+  scm_hashq_set_x (scm_source_whash, obj,
+                   scm_make_srcprops (line, col, fname,
+                                      SCM_COPY_SOURCE_P
+                                      ? scm_copy_tree (obj)
+                                      : SCM_UNDEFINED,
+                                      SCM_EOL));
+  scm_i_pthread_mutex_unlock (&source_lock);
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
             (SCM obj, SCM key),
 	    "Return the source property specified by @var{key} from\n"
@@ -194,7 +239,11 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
 {
   SCM p;
   SCM_VALIDATE_NIM (1, obj);
+
+  scm_i_pthread_mutex_lock (&source_lock);
   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+  scm_i_pthread_mutex_unlock (&source_lock);
+
   if (!SRCPROPSP (p))
     goto alist;
   if (scm_is_eq (scm_sym_line, key))
@@ -222,6 +271,8 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
 {
   SCM p;
   SCM_VALIDATE_NIM (1, obj);
+
+  scm_i_pthread_mutex_lock (&source_lock);
   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 
   if (scm_is_eq (scm_sym_line, key))
@@ -258,6 +309,8 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
 	scm_hashq_set_x (scm_source_whash, obj,
                          scm_acons (key, datum, p));
     }
+  scm_i_pthread_mutex_unlock (&source_lock);
+
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -272,10 +325,12 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
 {
   SCM p, z;
   z = scm_cons (x, y);
+  scm_i_pthread_mutex_lock (&source_lock);
   /* Copy source properties possibly associated with xorig. */
   p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F);
   if (scm_is_true (p))
     scm_hashq_set_x (scm_source_whash, z, p);
+  scm_i_pthread_mutex_unlock (&source_lock);
   return z;
 }
 #undef FUNC_NAME

libguile/srcprop.h

@@ -33,7 +33,6 @@
 #define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
 
 SCM_API scm_t_bits scm_tc16_srcprops;
-SCM_INTERNAL SCM scm_source_whash;
 
 SCM_API SCM scm_sym_filename;
 SCM_API SCM scm_sym_copy;
@@ -47,6 +46,9 @@ SCM_API SCM scm_source_property (SCM obj, SCM key);
 SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum);
 SCM_API SCM scm_source_properties (SCM obj);
 SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props);
+SCM_INTERNAL int scm_i_has_source_properties (SCM obj);
+SCM_INTERNAL void scm_i_set_source_properties_x (SCM obj, long line, int col,
+                                                 SCM fname);
 SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);
 SCM_INTERNAL void scm_init_srcprop (void);
 

libguile/stime.c

@@ -142,7 +142,11 @@ get_internal_real_time_posix_timer (void)
      ts.tv_nsec - posix_real_time_base.tv_nsec);
 }
 
-#ifdef _POSIX_CPUTIME
+#if defined _POSIX_CPUTIME && defined CLOCK_PROCESS_CPUTIME_ID
+/* You see, FreeBSD defines _POSIX_CPUTIME but not
+   CLOCK_PROCESS_CPUTIME_ID.  */
+#define HAVE_POSIX_CPUTIME 1
+
 struct timespec posix_run_time_base;
 
 static long
@@ -847,7 +851,7 @@ scm_init_stime()
   if (clock_gettime (CLOCK_REALTIME, &posix_real_time_base) == 0)
     get_internal_real_time = get_internal_real_time_posix_timer;
 
-#ifdef _POSIX_CPUTIME
+#ifdef HAVE_POSIX_CPUTIME
   {
     clockid_t dummy;
     
@@ -859,7 +863,7 @@ scm_init_stime()
     else
       errno = 0;
   }
-#endif /* _POSIX_CPUTIME */
+#endif /* HAVE_POSIX_CPUTIME */
 #endif /* HAVE_CLOCKTIME */
 
   /* If needed, init and use gettimeofday timer. */

libguile/symbols.c

@@ -52,6 +52,7 @@
 
 
 static SCM symbols;
+static scm_i_pthread_mutex_t symbols_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 #ifdef GUILE_DEBUG
 SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
@@ -108,13 +109,11 @@ lookup_interned_symbol (SCM name, unsigned long raw_hash)
   data.string = name;
   data.string_hash = raw_hash;
   
-  /* Strictly speaking, we should take a lock here.  But instead we rely
+  scm_i_pthread_mutex_lock (&symbols_lock);
-     on the fact that if this fails, we do take the lock on the
-     intern_symbol path; and since nothing deletes from the hash table
-     except GC, we should be OK.  */
   handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
                                            string_lookup_predicate_fn,
                                            &data);  
+  scm_i_pthread_mutex_unlock (&symbols_lock);
 
   if (scm_is_true (handle))
     return SCM_CAR (handle);
@@ -151,13 +150,11 @@ lookup_interned_latin1_symbol (const char *str, size_t len,
   data.len = len;
   data.string_hash = raw_hash;
   
-  /* Strictly speaking, we should take a lock here.  But instead we rely
+  scm_i_pthread_mutex_lock (&symbols_lock);
-     on the fact that if this fails, we do take the lock on the
-     intern_symbol path; and since nothing deletes from the hash table
-     except GC, we should be OK.  */
   handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
                                            latin1_lookup_predicate_fn,
                                            &data);  
+  scm_i_pthread_mutex_unlock (&symbols_lock);
 
   if (scm_is_true (handle))
     return SCM_CAR (handle);
@@ -187,8 +184,6 @@ symbol_lookup_assoc_fn (SCM obj, SCM alist, void *closure)
   return SCM_BOOL_F;
 }
 
-static scm_i_pthread_mutex_t intern_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
 /* Intern SYMBOL, an uninterned symbol.  Might return a different
    symbol, if another one was interned at the same time.  */
 static SCM
@@ -196,12 +191,12 @@ intern_symbol (SCM symbol)
 {
   SCM handle;
 
-  scm_i_pthread_mutex_lock (&intern_lock);
+  scm_i_pthread_mutex_lock (&symbols_lock);
   handle = scm_hash_fn_create_handle_x (symbols, symbol, SCM_UNDEFINED,
                                         symbol_lookup_hash_fn,
                                         symbol_lookup_assoc_fn,
                                         NULL);
-  scm_i_pthread_mutex_unlock (&intern_lock);
+  scm_i_pthread_mutex_unlock (&symbols_lock);
 
   return SCM_CAR (handle);
 }

module/ice-9/boot-9.scm

@@ -3043,15 +3043,15 @@ module '(ice-9 q) '(make-q q-length))}."
          #`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
         ((#:use-module (name name* ...) . args)
          (and (and-map symbol? (syntax->datum #'(name name* ...))))
-         (parse #'args (cons #'((name name* ...)) imp) exp rex rep aut))
+         (parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut))
         ((#:use-syntax (name name* ...) . args)
          (and (and-map symbol? (syntax->datum #'(name name* ...))))
          #`(#:transformer '(name name* ...)
-            . #,(parse #'args (cons #'((name name* ...)) imp) exp rex rep aut)))
+            . #,(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut)))
         ((#:use-module ((name name* ...) arg ...) . args)
          (and (and-map symbol? (syntax->datum #'(name name* ...))))
          (parse #'args
-                (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
+                #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
                 exp rex rep aut))
         ((#:export (ex ...) . args)
          (parse #'args imp #`(#,@exp ex ...) rex rep aut))

module/oop/goops.scm

@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 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
@@ -245,31 +245,28 @@
   (lambda (x)
     (syntax-case x ()
       ((_ (k arg rest ...) out ...)
-       (keyword? (syntax->datum (syntax k)))
+       (keyword? (syntax->datum #'k))
-       (case (syntax->datum (syntax k))
+       (case (syntax->datum #'k)
          ((#:getter #:setter)
-          (syntax
+          #'(define-class-pre-definition (rest ...)
-           (define-class-pre-definition (rest ...)
               out ...
               (if (or (not (defined? 'arg))
                       (not (is-a? arg <generic>)))
                   (toplevel-define!
                    'arg
-                  (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+                   (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
          ((#:accessor)
-          (syntax
+          #'(define-class-pre-definition (rest ...)
-           (define-class-pre-definition (rest ...)
               out ...
               (if (or (not (defined? 'arg))
                       (not (is-a? arg <accessor>)))
                   (toplevel-define!
                    'arg
-                  (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+                   (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
          (else
-          (syntax
+          #'(define-class-pre-definition (rest ...) out ...))))
-           (define-class-pre-definition (rest ...) out ...)))))
       ((_ () out ...)
-       (syntax (begin out ...))))))
+       #'(begin out ...)))))
        
 ;; Some slot options require extra definitions to be made. In
 ;; particular, we want to make sure that the generic function objects
@@ -279,17 +276,17 @@
   (lambda (x)
     (syntax-case x ()
       ((_ () out ...)
-       (syntax (begin out ...)))
+       #'(begin out ...))
       ((_ (slot rest ...) out ...)
-       (keyword? (syntax->datum (syntax slot)))
+       (keyword? (syntax->datum #'slot))
-       (syntax (begin out ...)))
+       #'(begin out ...))
       ((_ (slot rest ...) out ...)
-       (identifier? (syntax slot))
+       (identifier? #'slot)
-       (syntax (define-class-pre-definitions (rest ...)
+       #'(define-class-pre-definitions (rest ...)
-                 out ...)))
+         out ...))
       ((_ ((slotname slotopt ...) rest ...) out ...)
-       (syntax (define-class-pre-definitions (rest ...) 
+       #'(define-class-pre-definitions (rest ...) 
-                 out ... (define-class-pre-definition (slotopt ...))))))))
+         out ... (define-class-pre-definition (slotopt ...)))))))
 
 (define-syntax define-class
   (syntax-rules ()
@@ -491,46 +488,46 @@
       (let lp ((ls args) (formals '()) (specializers '()))
         (syntax-case ls ()
           (((f s) . rest)
-           (and (identifier? (syntax f)) (identifier? (syntax s)))
+           (and (identifier? #'f) (identifier? #'s))
-           (lp (syntax rest)
+           (lp #'rest
-               (cons (syntax f) formals)
+               (cons #'f formals)
-               (cons (syntax s) specializers)))
+               (cons #'s specializers)))
           ((f . rest)
-           (identifier? (syntax f))
+           (identifier? #'f)
-           (lp (syntax rest)
+           (lp #'rest
-               (cons (syntax f) formals)
+               (cons #'f formals)
-               (cons (syntax <top>) specializers)))
+               (cons #'<top> specializers)))
           (()
            (list (reverse formals)
-                 (reverse (cons (syntax '()) specializers))))
+                 (reverse (cons #''() specializers))))
           (tail
-           (identifier? (syntax tail))
+           (identifier? #'tail)
-           (list (append (reverse formals) (syntax tail))
+           (list (append (reverse formals) #'tail)
-                 (reverse (cons (syntax <top>) specializers)))))))
+                 (reverse (cons #'<top> specializers)))))))
 
     (define (find-free-id exp referent)
       (syntax-case exp ()
         ((x . y)
-         (or (find-free-id (syntax x) referent)
+         (or (find-free-id #'x referent)
-             (find-free-id (syntax y) referent)))
+             (find-free-id #'y referent)))
         (x
-         (identifier? (syntax x))
+         (identifier? #'x)
-         (let ((id (datum->syntax (syntax x) referent)))
+         (let ((id (datum->syntax #'x referent)))
-           (and (free-identifier=? (syntax x) id) id)))
+           (and (free-identifier=? #'x id) id)))
         (_ #f)))
 
     (define (compute-procedure formals body)
       (syntax-case body ()
         ((body0 ...)
          (with-syntax ((formals formals))
-           (syntax (lambda formals body0 ...))))))
+           #'(lambda formals body0 ...)))))
 
     (define (->proper args)
       (let lp ((ls args) (out '()))
         (syntax-case ls ()
-          ((x . xs)        (lp (syntax xs) (cons (syntax x) out)))
+          ((x . xs)        (lp #'xs (cons #'x out)))
           (()              (reverse out))
-          (tail            (reverse (cons (syntax tail) out))))))
+          (tail            (reverse (cons #'tail out))))))
 
     (define (compute-make-procedure formals body next-method)
       (syntax-case body ()
@@ -538,24 +535,22 @@
          (with-syntax ((next-method next-method))
            (syntax-case formals ()
              ((formal ...)
-              (syntax
+              #'(lambda (real-next-method)
-               (lambda (real-next-method)
                   (lambda (formal ...)
                     (let ((next-method (lambda args
                                          (if (null? args)
                                              (real-next-method formal ...)
                                              (apply real-next-method args)))))
-                     body ...)))))
+                      body ...))))
              (formals
-              (with-syntax (((formal ...) (->proper (syntax formals))))
+              (with-syntax (((formal ...) (->proper #'formals)))
-                (syntax
+                #'(lambda (real-next-method)
-                 (lambda (real-next-method)
                     (lambda formals
                       (let ((next-method (lambda args
                                            (if (null? args)
                                                (apply real-next-method formal ...)
                                                (apply real-next-method args)))))
-                       body ...)))))))))))
+                        body ...))))))))))
 
     (define (compute-procedures formals body)
       ;; So, our use of this is broken, because it operates on the
@@ -564,28 +559,27 @@
       (let ((id (find-free-id body 'next-method)))
         (if id
             ;; return a make-procedure
-            (values (syntax #f)
+            (values #'#f
                     (compute-make-procedure formals body id))
             (values (compute-procedure formals body)
-                    (syntax #f)))))
+                    #'#f))))
 
     (syntax-case x ()
-      ((_ args) (syntax (method args (if #f #f))))
+      ((_ args) #'(method args (if #f #f)))
       ((_ args body0 body1 ...)
-       (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
+       (with-syntax (((formals (specializer ...)) (parse-args #'args)))
          (call-with-values
              (lambda ()
-               (compute-procedures (syntax formals) (syntax (body0 body1 ...))))
+               (compute-procedures #'formals #'(body0 body1 ...)))
            (lambda (procedure make-procedure)
              (with-syntax ((procedure procedure)
                            (make-procedure make-procedure))
-               (syntax
+               #'(make <method>
-                (make <method>
                    #:specializers (cons* specializer ...)
                    #:formals 'formals
                    #:body '(body0 body1 ...)
                    #:make-procedure make-procedure
-                  #:procedure procedure))))))))))
+                   #:procedure procedure)))))))))
 
 ;;;
 ;;; {add-method!}

module/rnrs/io/ports.scm

@@ -170,7 +170,7 @@
 ;;;
 
 (define (with-i/o-filename-conditions filename thunk)
-  (catch 'system-error
+  (with-throw-handler 'system-error
       thunk
     (lambda args
       (let ((errno (system-error-errno args)))
@@ -187,6 +187,28 @@
                       make-i/o-filename-error))))
           (raise (construct-condition filename)))))))
 
+(define (with-i/o-port-error port make-primary-condition thunk)
+  (with-throw-handler 'system-error
+      thunk
+    (lambda args
+      (let ((errno (system-error-errno args)))
+        (if (memv errno (list EIO EFBIG ENOSPC EPIPE))
+            (raise (condition (make-primary-condition)
+                              (make-i/o-port-error port)))
+            (apply throw args))))))
+
+(define-syntax with-textual-output-conditions
+  (syntax-rules ()
+    ((_ port body0 body ...)
+     (with-i/o-port-error port make-i/o-write-error
+       (lambda () (with-i/o-encoding-error body0 body ...))))))
+
+(define-syntax with-textual-input-conditions
+  (syntax-rules ()
+    ((_ port body0 body ...)
+     (with-i/o-port-error port make-i/o-read-error
+       (lambda () (with-i/o-decoding-error body0 body ...))))))
+
 
 ;;;
 ;;; Input and output ports.
@@ -313,7 +335,10 @@ as a string, and a thunk to retrieve the characters associated with that port."
                             O_CREAT)
                         (if (enum-set-member? 'no-truncate file-options)
                             0
-                            O_TRUNC)))
+                            O_TRUNC)
+                        (if (enum-set-member? 'no-fail file-options)
+                            0
+                            O_EXCL)))
          (port (with-i/o-filename-conditions filename
                  (lambda () (open filename flags)))))
     (cond (maybe-transcoder
@@ -363,13 +388,13 @@ return the characters accumulated in that port."
          (raise (make-i/o-encoding-error port chr)))))))
 
 (define (put-char port char)
-  (with-i/o-encoding-error (write-char char port)))
+  (with-textual-output-conditions port (write-char char port)))
 
 (define (put-datum port datum)
-  (with-i/o-encoding-error (write datum port)))
+  (with-textual-output-conditions port (write datum port)))
 
 (define* (put-string port s #:optional start count)
-  (with-i/o-encoding-error
+  (with-textual-output-conditions port
    (cond ((not (string? s))
           (assertion-violation 'put-string "expected string" s))
          ((and start count)
@@ -382,8 +407,7 @@ return the characters accumulated in that port."
 ;; Defined here to be able to make use of `with-i/o-encoding-error', but
 ;; not exported from here, but from `(rnrs io simple)'.
 (define* (display object #:optional (port (current-output-port)))
-  (with-i/o-encoding-error
+  (with-textual-output-conditions port (guile:display object port)))
-    (guile:display object port)))
 
 
 ;;;
@@ -406,16 +430,16 @@ return the characters accumulated in that port."
          (raise (make-i/o-decoding-error port)))))))
 
 (define (get-char port)
-  (with-i/o-decoding-error (read-char port)))
+  (with-textual-input-conditions port (read-char port)))
 
 (define (get-datum port)
-  (with-i/o-decoding-error (read port)))
+  (with-textual-input-conditions port (read port)))
 
 (define (get-line port)
-  (with-i/o-decoding-error (read-line port 'trim)))
+  (with-textual-input-conditions port (read-line port 'trim)))
 
 (define (get-string-all port)
-  (with-i/o-decoding-error (read-delimited "" port 'concat)))
+  (with-textual-input-conditions port (read-delimited "" port 'concat)))
 
 (define (get-string-n port count)
   "Read up to @var{count} characters from @var{port}.
@@ -429,7 +453,7 @@ the characters read."
           (else             (substring/shared s 0 rv)))))
 
 (define (lookahead-char port)
-  (with-i/o-decoding-error (peek-char port)))
+  (with-textual-input-conditions port (peek-char port)))
 
 
 ;;;

test-suite/standalone/Makefile.am

@@ -31,6 +31,7 @@ BUILT_SOURCES =
 EXTRA_DIST =
 
 TESTS_ENVIRONMENT =						\
+  srcdir="$(srcdir)"						\
   builddir="$(builddir)"					\
   GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
 
@@ -75,6 +76,11 @@ TESTS += test-require-extension
 check_SCRIPTS += test-guile-snarf
 TESTS += test-guile-snarf
 
+check_SCRIPTS += test-import-order
+TESTS += test-import-order
+EXTRA_DIST += test-import-order-a.scm test-import-order-b.scm \
+  test-import-order-c.scm test-import-order-d.scm
+
 # test-num2integral
 test_num2integral_SOURCES = test-num2integral.c
 test_num2integral_CFLAGS = ${test_cflags}

test-suite/standalone/test-import-order

@@ -0,0 +1,31 @@
+#!/bin/sh
+exec guile -q -L "$srcdir" -s "$0" "$@"
+!#
+
+(define-module (base)
+  #:export (push! order))
+
+(define order '())
+(define (push!)
+  (set! order `(,@order ,(module-name (current-module)))))
+
+(define-module (test-1)
+  #:use-module (base)
+  #:use-module (test-import-order-a)
+  #:use-module (test-import-order-b))
+
+(use-modules (test-import-order-c) (test-import-order-d))
+
+(if (not (equal? order
+                 '((test-import-order-a)
+                   (test-import-order-b)
+                   (test-import-order-c)
+                   (test-import-order-d))))
+    (begin
+      (format (current-error-port) "Unexpected import order: ~a" order)
+      (exit 1))
+    (exit 0))
+
+;; Local Variables:
+;; mode: scheme
+;; End:

test-suite/standalone/test-import-order-a.scm

@@ -0,0 +1,4 @@
+(define-module (test-import-order-a)
+  #:use-module (base))
+
+(push!)

test-suite/standalone/test-import-order-b.scm

@@ -0,0 +1,4 @@
+(define-module (test-import-order-b)
+  #:use-module (base))
+
+(push!)

test-suite/standalone/test-import-order-c.scm

@@ -0,0 +1,4 @@
+(define-module (test-import-order-c)
+  #:use-module (base))
+
+(push!)

test-suite/standalone/test-import-order-d.scm

@@ -0,0 +1,4 @@
+(define-module (test-import-order-d)
+  #:use-module (base))
+
+(push!)

test-suite/tests/r6rs-ports.test

@@ -19,9 +19,11 @@
 
 (define-module (test-io-ports)
   #:use-module (test-suite lib)
+  #:use-module (test-suite guile-test)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (rnrs io ports)
+  #:use-module (rnrs io simple)
   #:use-module (rnrs exceptions)
   #:use-module (rnrs bytevectors))
 
@@ -31,6 +33,45 @@
 ;; Set the default encoding of future ports to be Latin-1.
 (fluid-set! %default-port-encoding #f)
 
+(define-syntax pass-if-condition
+  (syntax-rules ()
+    ((_ name predicate body0 body ...)
+     (let ((cookie (list 'cookie)))
+       (pass-if name
+         (eq? cookie (guard (c ((predicate c) cookie))
+                       body0 body ...)))))))
+
+(define (test-file)
+  (data-file-name "ports-test.tmp"))
+
+;; A input/output port that swallows all output, and produces just
+;; spaces on input.  Reading and writing beyond `failure-position'
+;; produces `system-error' exceptions.  Used for testing exception
+;; behavior.
+(define* (make-failing-port #:optional (failure-position 0))
+  (define (maybe-fail index errno)
+    (if (> index failure-position)
+        (scm-error 'system-error
+                   'failing-port
+                   "I/O beyond failure position" '()
+                   (list errno))))
+  (let ((read-index  0)
+        (write-index 0))
+    (define (write-char chr)
+      (set! write-index (+ 1 write-index))
+      (maybe-fail write-index ENOSPC))
+    (make-soft-port
+     (vector write-char
+             (lambda (str)   ;; write-string
+               (for-each write-char (string->list str)))
+             (lambda () #t)  ;; flush-output
+             (lambda ()      ;; read-char
+               (set! read-index (+ read-index 1))
+               (maybe-fail read-index EIO)
+               #\space)
+             (lambda () #t)) ;; close-port
+     "rw")))
+
 
 (with-test-prefix "7.2.5 End-of-File Object"
 
@@ -421,6 +462,37 @@
 
 (with-test-prefix "8.2.10 Output ports"
 
+  (let ((filename (test-file)))
+    (pass-if "open-file-output-port [opens binary port]"
+      (call-with-port (open-file-output-port filename)
+        (lambda (port)
+          (put-bytevector port '#vu8(1 2 3))
+          (binary-port? port))))
+    
+    (pass-if-condition "open-file-output-port [exception: already-exists]"
+        i/o-file-already-exists-error?
+      (open-file-output-port filename))
+    
+    (pass-if "open-file-output-port [no-fail no-truncate]"
+      (and
+        (call-with-port (open-file-output-port filename
+                                               (file-options no-fail no-truncate))
+          (lambda (port)
+            (= 0 (port-position port))))
+        (= 3 (stat:size (stat filename)))))
+
+    (pass-if "open-file-output-port [no-fail]"
+      (and
+        (call-with-port (open-file-output-port filename (file-options no-fail))
+          binary-port?)
+        (= 0 (stat:size (stat filename)))))
+    
+    (delete-file filename)
+    
+    (pass-if-condition "open-file-output-port [exception: does-not-exist]"
+        i/o-file-does-not-exist-error?
+      (open-file-output-port filename (file-options no-create))))
+  
   (pass-if "open-bytevector-output-port"
     (let-values (((port get-content)
                   (open-bytevector-output-port #f)))
@@ -627,7 +699,69 @@
     (let ((port (open-input-string "GNU Guile"))
           (s (string-copy "Isn't XXX great?")))
       (and (= 3 (get-string-n! port s 6 3))
-           (string=? s "Isn't GNU great?")))))
+           (string=? s "Isn't GNU great?"))))
+
+  (with-test-prefix "read error"
+    (pass-if-condition "get-char" i/o-read-error?
+      (get-char (make-failing-port)))
+    (pass-if-condition "lookahead-char" i/o-read-error?
+      (lookahead-char (make-failing-port)))
+    ;; FIXME: these are not yet exception-correct
+    #|
+    (pass-if-condition "get-string-n" i/o-read-error?
+      (get-string-n (make-failing-port) 5))
+    (pass-if-condition "get-string-n!" i/o-read-error?
+      (get-string-n! (make-failing-port) (make-string 5) 0 5))
+    |#
+    (pass-if-condition "get-string-all" i/o-read-error?
+      (get-string-all (make-failing-port 100)))
+    (pass-if-condition "get-line" i/o-read-error?
+      (get-line (make-failing-port)))
+    (pass-if-condition "get-datum" i/o-read-error?
+      (get-datum (make-failing-port)))))
+
+(with-test-prefix "8.2.12 Textual Output"
+  
+  (with-test-prefix "write error"
+    (pass-if-condition "put-char" i/o-write-error?
+      (put-char (make-failing-port) #\G))
+    (pass-if-condition "put-string" i/o-write-error?
+      (put-string (make-failing-port) "Hello World!"))
+    (pass-if-condition "put-datum" i/o-write-error?
+      (put-datum (make-failing-port) '(hello world!)))))
+
+(with-test-prefix "8.3 Simple I/O"
+  (with-test-prefix "read error"
+    (pass-if-condition "read-char" i/o-read-error?
+      (read-char (make-failing-port)))
+    (pass-if-condition "peek-char" i/o-read-error?
+      (peek-char (make-failing-port)))
+    (pass-if-condition "read" i/o-read-error?
+      (read (make-failing-port))))
+  (with-test-prefix "write error"
+    (pass-if-condition "display" i/o-write-error?
+      (display "Hi there!" (make-failing-port)))
+    (pass-if-condition "write" i/o-write-error?
+      (write '(hi there!) (make-failing-port)))
+    (pass-if-condition "write-char" i/o-write-error?
+      (write-char #\G (make-failing-port)))
+    (pass-if-condition "newline" i/o-write-error?
+      (newline (make-failing-port))))
+  (let ((filename (test-file)))
+    ;; ensure the test file exists
+    (call-with-output-file filename
+      (lambda (port) (write "foo" port)))
+    (pass-if "call-with-input-file [port is textual]"
+      (call-with-input-file filename textual-port?))
+    (pass-if-condition "call-with-input-file [exception: not-found]"
+        i/o-file-does-not-exist-error?
+      (call-with-input-file ",this-is-highly-unlikely-to-exist!"
+        values))
+    (pass-if-condition "call-with-output-file [exception: already-exists]"
+        i/o-file-already-exists-error?
+      (call-with-output-file filename
+        values))
+    (delete-file filename)))
 
 ;;; Local Variables:
 ;;; mode: scheme