diff options
author | Andy Wingo <wingo@pobox.com> | 2011-05-25 10:32:19 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-05-25 10:32:19 +0200 |
commit | a099c8d971c1d5b32e00f25469b36ce45fd4d8c7 (patch) | |
tree | 350e16d9e9e01c95c366aa44ba31d03bf57ac83c | |
parent | 9ec1573d2b9463043df79b9a2cb30acc6afaeaaa (diff) | |
parent | 7ad0737de9b7bbb5f4f938518b4905b526d13ca6 (diff) | |
download | guile-a099c8d971c1d5b32e00f25469b36ce45fd4d8c7.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/procprop.c
-rw-r--r-- | doc/ref/api-debug.texi | 9 | ||||
-rw-r--r-- | doc/ref/api-evaluation.texi | 14 | ||||
-rw-r--r-- | doc/ref/api-io.texi | 8 | ||||
-rw-r--r-- | doc/ref/repl-modules.texi | 36 | ||||
-rw-r--r-- | libguile/Makefile.am | 11 | ||||
-rw-r--r-- | libguile/filesys.c | 2 | ||||
-rw-r--r-- | libguile/goops.c | 12 | ||||
-rw-r--r-- | libguile/procprop.c | 10 | ||||
-rw-r--r-- | libguile/read.c | 119 | ||||
-rw-r--r-- | libguile/smob.c | 15 | ||||
-rw-r--r-- | libguile/srcprop.c | 59 | ||||
-rw-r--r-- | libguile/srcprop.h | 4 | ||||
-rw-r--r-- | libguile/stime.c | 10 | ||||
-rw-r--r-- | libguile/symbols.c | 19 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 6 | ||||
-rw-r--r-- | module/oop/goops.scm | 152 | ||||
-rw-r--r-- | module/rnrs/io/ports.scm | 78 | ||||
-rw-r--r-- | test-suite/standalone/Makefile.am | 6 | ||||
-rwxr-xr-x | test-suite/standalone/test-import-order | 31 | ||||
-rw-r--r-- | test-suite/standalone/test-import-order-a.scm | 4 | ||||
-rw-r--r-- | test-suite/standalone/test-import-order-b.scm | 4 | ||||
-rw-r--r-- | test-suite/standalone/test-import-order-c.scm | 4 | ||||
-rw-r--r-- | test-suite/standalone/test-import-order-d.scm | 4 | ||||
-rw-r--r-- | test-suite/tests/r6rs-ports.test | 136 |
24 files changed, 470 insertions, 283 deletions
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 765b4ad8d..bdb616656 100644 --- a/doc/ref/api-debug.texi +++ b/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 diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 9430c744d..e87331086 100644 --- a/doc/ref/api-evaluation.texi +++ b/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 -Modify the print options. +@deffn {Scheme Syntax} print-set! option-name value +Modify the print options. Due to historical oddities, @code{print-set!} +is a macro that expects an unquoted option name. @end deffn diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 09fdc8331..19c066530 100644 --- a/doc/ref/api-io.texi +++ b/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 diff --git a/doc/ref/repl-modules.texi b/doc/ref/repl-modules.texi index 78c7eee1e..700867272 100644 --- a/doc/ref/repl-modules.texi +++ b/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 -better suit the user's needs. Configuration is done via the readline -module's options interface, in a similar way to the evaluator and -debugging options (@pxref{Runtime Options}). - -@findex readline-options -@findex readline-enable -@findex readline-disable -@findex readline-set! +The readline interface module can be tweaked in a few ways to better +suit the user's needs. Configuration is done via the readline module's +options interface, in a similar way to the evaluator and debugging +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 + 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. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 263d6b04c..6f2f79367 100644 --- a/libguile/Makefile.am +++ b/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. -## For some reason, OBJEXT does not include the dot +## Override default rule; this should be compiled for BUILD host. Note +## 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 diff --git a/libguile/filesys.c b/libguile/filesys.c index b43536f0a..2429e80a6 100644 --- a/libguile/filesys.c +++ b/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; diff --git a/libguile/goops.c b/libguile/goops.c index 925f094b6..8ed37fac5 100644 --- a/libguile/goops.c +++ b/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)) @@ -219,8 +224,12 @@ scm_i_define_class_for_vtable (SCM vtable) else /* `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); } diff --git a/libguile/procprop.c b/libguile/procprop.c index 39f573700..ac2fa12a8 100644 --- a/libguile/procprop.c +++ b/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); diff --git a/libguile/read.c b/libguile/read.c index 098854bb4..6e7804dd8 100644 --- a/libguile/read.c +++ b/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; - register SCM tmp; - register SCM tl, ans = SCM_EOL; - SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F; + int c; + SCM tmp, tl, ans = SCM_EOL; 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, - ans, - scm_make_srcprops (line, column, - SCM_FILENAME (port), - SCM_COPY_SOURCE_P - ? ans2 - : SCM_UNDEFINED, - SCM_EOL)); + scm_i_set_source_properties_x (ans, line, column, SCM_FILENAME (port)); + 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_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)); - + scm_i_set_source_properties_x (p, line, column, SCM_FILENAME (port)); 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_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)); - + scm_i_set_source_properties_x (p, line, column, SCM_FILENAME (port)); return p; } @@ -1332,14 +1285,11 @@ 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_RECORD_POSITIONS_P) - return (recsexpr (got, line, column, - SCM_FILENAME (port))); - else - return got; - } + + if (scm_is_pair (got) && !scm_i_has_source_properties (got)) + scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port)); + + 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, diff --git a/libguile/smob.c b/libguile/smob.c index adb34ba0b..c414913fc 100644 --- a/libguile/smob.c +++ b/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 - weak pair */ - SCM tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F); + SCM tramp; + + 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; } } diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 4eb1ccaac..dc333d46c 100644 --- a/libguile/srcprop.c +++ b/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); - p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); + + 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 diff --git a/libguile/srcprop.h b/libguile/srcprop.h index 5c9ccb960..250756dcc 100644 --- a/libguile/srcprop.h +++ b/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); diff --git a/libguile/stime.c b/libguile/stime.c index 1c4f407f9..dda82e720 100644 --- a/libguile/stime.c +++ b/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. */ diff --git a/libguile/symbols.c b/libguile/symbols.c index 2a1b46dce..59aca002e 100644 --- a/libguile/symbols.c +++ b/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 - 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. */ + scm_i_pthread_mutex_lock (&symbols_lock); 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 - 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. */ + scm_i_pthread_mutex_lock (&symbols_lock); 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); } diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 6dab79eea..0493de514 100644 --- a/module/ice-9/boot-9.scm +++ b/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)) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 2801aa25b..1f9fd5074 100644 --- a/module/oop/goops.scm +++ b/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))) - (case (syntax->datum (syntax k)) + (keyword? (syntax->datum #'k)) + (case (syntax->datum #'k) ((#:getter #:setter) - (syntax - (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)))))) + #'(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))))) ((#:accessor) - (syntax - (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)))))) + #'(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))))) (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))) - (syntax (begin out ...))) + (keyword? (syntax->datum #'slot)) + #'(begin out ...)) ((_ (slot rest ...) out ...) - (identifier? (syntax slot)) - (syntax (define-class-pre-definitions (rest ...) - out ...))) + (identifier? #'slot) + #'(define-class-pre-definitions (rest ...) + out ...)) ((_ ((slotname slotopt ...) rest ...) out ...) - (syntax (define-class-pre-definitions (rest ...) - out ... (define-class-pre-definition (slotopt ...)))))))) + #'(define-class-pre-definitions (rest ...) + 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))) - (lp (syntax rest) - (cons (syntax f) formals) - (cons (syntax s) specializers))) + (and (identifier? #'f) (identifier? #'s)) + (lp #'rest + (cons #'f formals) + (cons #'s specializers))) ((f . rest) - (identifier? (syntax f)) - (lp (syntax rest) - (cons (syntax f) formals) - (cons (syntax <top>) specializers))) + (identifier? #'f) + (lp #'rest + (cons #'f formals) + (cons #'<top> specializers))) (() (list (reverse formals) - (reverse (cons (syntax '()) specializers)))) + (reverse (cons #''() specializers)))) (tail - (identifier? (syntax tail)) - (list (append (reverse formals) (syntax tail)) - (reverse (cons (syntax <top>) specializers))))))) + (identifier? #'tail) + (list (append (reverse formals) #'tail) + (reverse (cons #'<top> specializers))))))) (define (find-free-id exp referent) (syntax-case exp () ((x . y) - (or (find-free-id (syntax x) referent) - (find-free-id (syntax y) referent))) + (or (find-free-id #'x referent) + (find-free-id #'y referent))) (x - (identifier? (syntax x)) - (let ((id (datum->syntax (syntax x) referent))) - (and (free-identifier=? (syntax x) id) id))) + (identifier? #'x) + (let ((id (datum->syntax #'x referent))) + (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 (formal ...) - (let ((next-method (lambda args - (if (null? args) - (real-next-method formal ...) - (apply real-next-method args))))) - body ...))))) + #'(lambda (real-next-method) + (lambda (formal ...) + (let ((next-method (lambda args + (if (null? args) + (real-next-method formal ...) + (apply real-next-method args))))) + body ...)))) (formals - (with-syntax (((formal ...) (->proper (syntax formals)))) - (syntax - (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 ...))))))))))) + (with-syntax (((formal ...) (->proper #'formals))) + #'(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 ...)))))))))) (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> - #:specializers (cons* specializer ...) - #:formals 'formals - #:body '(body0 body1 ...) - #:make-procedure make-procedure - #:procedure procedure)))))))))) + #'(make <method> + #:specializers (cons* specializer ...) + #:formals 'formals + #:body '(body0 body1 ...) + #:make-procedure make-procedure + #:procedure procedure))))))))) ;;; ;;; {add-method!} diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 3dbaa039b..4ae01be68 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -170,22 +170,44 @@ ;;; (define (with-i/o-filename-conditions filename thunk) - (catch 'system-error - thunk - (lambda args - (let ((errno (system-error-errno args))) - (let ((construct-condition - (cond ((= errno EACCES) - make-i/o-file-protection-error) - ((= errno EEXIST) - make-i/o-file-already-exists-error) - ((= errno ENOENT) - make-i/o-file-does-not-exist-error) - ((= errno EROFS) - make-i/o-file-is-read-only-error) - (else - make-i/o-filename-error)))) - (raise (construct-condition filename))))))) + (with-throw-handler 'system-error + thunk + (lambda args + (let ((errno (system-error-errno args))) + (let ((construct-condition + (cond ((= errno EACCES) + make-i/o-file-protection-error) + ((= errno EEXIST) + make-i/o-file-already-exists-error) + ((= errno ENOENT) + make-i/o-file-does-not-exist-error) + ((= errno EROFS) + make-i/o-file-is-read-only-error) + (else + 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 ...)))))) ;;; @@ -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 - (guile:display object port))) + (with-textual-output-conditions 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))) ;;; diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index cf1fc4fe3..00655bd12 100644 --- a/test-suite/standalone/Makefile.am +++ b/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} diff --git a/test-suite/standalone/test-import-order b/test-suite/standalone/test-import-order new file mode 100755 index 000000000..8b51312a9 --- /dev/null +++ b/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:
\ No newline at end of file diff --git a/test-suite/standalone/test-import-order-a.scm b/test-suite/standalone/test-import-order-a.scm new file mode 100644 index 000000000..d6fa29def --- /dev/null +++ b/test-suite/standalone/test-import-order-a.scm @@ -0,0 +1,4 @@ +(define-module (test-import-order-a) + #:use-module (base)) + +(push!) diff --git a/test-suite/standalone/test-import-order-b.scm b/test-suite/standalone/test-import-order-b.scm new file mode 100644 index 000000000..bc41bdf9f --- /dev/null +++ b/test-suite/standalone/test-import-order-b.scm @@ -0,0 +1,4 @@ +(define-module (test-import-order-b) + #:use-module (base)) + +(push!) diff --git a/test-suite/standalone/test-import-order-c.scm b/test-suite/standalone/test-import-order-c.scm new file mode 100644 index 000000000..4b58c3d75 --- /dev/null +++ b/test-suite/standalone/test-import-order-c.scm @@ -0,0 +1,4 @@ +(define-module (test-import-order-c) + #:use-module (base)) + +(push!) diff --git a/test-suite/standalone/test-import-order-d.scm b/test-suite/standalone/test-import-order-d.scm new file mode 100644 index 000000000..fb071be93 --- /dev/null +++ b/test-suite/standalone/test-import-order-d.scm @@ -0,0 +1,4 @@ +(define-module (test-import-order-d) + #:use-module (base)) + +(push!) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 06431bb76..7a382b75b 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/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 |