diff options
author | Andy Wingo <wingo@pobox.com> | 2012-01-10 00:41:42 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-01-10 00:41:42 +0100 |
commit | 91ee7515da0bad91330ce5c87b250d6cf12a2789 (patch) | |
tree | ce023c92c0d9bf895c1265b107b270c35ba59b94 | |
parent | 0bdd43515eb3c62839512181cf33e5aea383e661 (diff) | |
parent | 0e947e1d14597651c5762a4209225c472bdaef45 (diff) |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/__scm.h
libguile/array-map.c
libguile/procprop.c
libguile/tags.h
module/ice-9/deprecated.scm
module/ice-9/psyntax-pp.scm
module/ice-9/psyntax.scm
test-suite/standalone/test-num2integral.c
test-suite/tests/regexp.test
64 files changed, 1025 insertions, 649 deletions
diff --git a/.x-sc_bindtextdomain b/.x-sc_bindtextdomain new file mode 100644 index 000000000..72e8ffc0d --- /dev/null +++ b/.x-sc_bindtextdomain @@ -0,0 +1 @@ +* diff --git a/.x-sc_error_message_uppercase b/.x-sc_error_message_uppercase index 25078a12b..cc3fe0ddd 100644 --- a/.x-sc_error_message_uppercase +++ b/.x-sc_error_message_uppercase @@ -4,3 +4,4 @@ ^emacs/ ^NEWS ^doc/ +^test-suite/tests/ports.test diff --git a/.x-sc_obsolete_symbols b/.x-sc_obsolete_symbols index 5b1140cef..6f9b57d5a 100644 --- a/.x-sc_obsolete_symbols +++ b/.x-sc_obsolete_symbols @@ -1,4 +1,5 @@ doc/* lib/flock.c +lib/fcntl.in.h libguile/filesys.c libguile/ChangeLog-2008 diff --git a/.x-sc_prohibit_doubled_word b/.x-sc_prohibit_doubled_word new file mode 100644 index 000000000..fe2d3d02a --- /dev/null +++ b/.x-sc_prohibit_doubled_word @@ -0,0 +1,7 @@ +^AUTHORS +^gc-benchmarks/larceny/ +^module/ice-9/format.scm +^module/ice-9/match.upstream.scm +^module/sxml/upstream +compile.scm +ChangeLog diff --git a/.x-sc_prohibit_have_config_h b/.x-sc_prohibit_have_config_h new file mode 100644 index 000000000..4f18e845c --- /dev/null +++ b/.x-sc_prohibit_have_config_h @@ -0,0 +1,5 @@ +libguile/* +srfi/* +test-suite/* +guile-readline/* +lib/* diff --git a/.x-sc_prohibit_magic_number_exit b/.x-sc_prohibit_magic_number_exit index adcd138ba..3aac7a4b3 100644 --- a/.x-sc_prohibit_magic_number_exit +++ b/.x-sc_prohibit_magic_number_exit @@ -2,3 +2,4 @@ configure.ac NEWS doc/ref/api-init.texi libguile/ChangeLog* +m4/* diff --git a/.x-sc_prohibit_path_max_allocation b/.x-sc_prohibit_path_max_allocation new file mode 100644 index 000000000..4e46d8b6a --- /dev/null +++ b/.x-sc_prohibit_path_max_allocation @@ -0,0 +1,2 @@ +libguile/win32-socket.c +lib/stat.c diff --git a/.x-sc_prohibit_strcmp b/.x-sc_prohibit_strcmp new file mode 100644 index 000000000..784791f50 --- /dev/null +++ b/.x-sc_prohibit_strcmp @@ -0,0 +1,3 @@ +m4/* +lib/* +test-suite/* @@ -1,6 +1,6 @@ -*-text-*- Guile Hacking Guide -Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008 Free software Foundation, Inc. +Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008, 2012 Free software Foundation, Inc. Permission is granted to anyone to make or distribute verbatim copies of this document as received, in any medium, provided that the @@ -222,7 +222,7 @@ When deprecating a definition, always follow this procedure: manage without the deprecated definition. 4. Add an entry that the definition has been deprecated in NEWS and - explain what do do instead. + explain what to do instead. 5. In file TODO, there is a list of releases with reminders about what to do at each release. Add a reminder about the removal of the @@ -1,5 +1,5 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2011 Free Software Foundation, Inc. +Copyright (C) 1996-2012 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. @@ -1386,7 +1386,7 @@ Arguments", and "Case-lambda" in the manual. Instead of accessing a procedure's arity as a property, use the new `procedure-minimum-arity' function, which gives the most permissive -arity that the the function has, in the same format as the old arity +arity that the function has, in the same format as the old arity accessor. ** `lambda*' and `define*' are now available in the default environment @@ -2156,7 +2156,7 @@ allocated to primitive procedures, each with its own calling convention. Now there is only one, the gsubr. This may affect user code if you were defining a procedure using scm_c_make_subr rather scm_c_make_gsubr. The solution is to switch to use scm_c_make_gsubr. This solution works well -both with the old 1.8 and and with the current 1.9 branch. +both with the old 1.8 and with the current 1.9 branch. Guile's old evaluator used to have special cases for applying "gsubrs", primitive procedures with specified numbers of required, optional, and @@ -6193,7 +6193,7 @@ incrementally add to the innermost environment, without checking whether the restrictions specified in RnRS were met. This lead to the correct behaviour when these restriction actually were met, but didn't catch all illegal uses. Such an illegal use could lead to crashes of -the Guile interpreter or or other unwanted results. An example of +the Guile interpreter or other unwanted results. An example of incorrect internal defines that made Guile behave erratically: (let () diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index d521f980b..c0570f24b 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -7132,7 +7132,7 @@ with the strings in the list @var{ls}. @deffn {Scheme Procedure} string-concatenate-reverse/shared ls [final_string [end]] @deffnx {C Function} scm_string_concatenate_reverse_shared (ls, final_string, end) Like @code{string-concatenate-reverse}, but the result may -share memory with the the strings in the @var{ls} arguments. +share memory with the strings in the @var{ls} arguments. @end deffn string-map diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index da8ca9199..03891fac4 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1560,7 +1560,7 @@ same type, and have corresponding elements which are either @c FIXME: array-for-each doesn't say what happens if the sources have @c different index ranges. The code currently iterates over the @c indices of the first and expects the others to cover those. That -@c at least vaguely matches array-map!, but is is meant to be a +@c at least vaguely matches array-map!, but is it meant to be a @c documented feature? @deffn {Scheme Procedure} array-map! dst proc src1 @dots{} srcN diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 957b9a763..c1502b032 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.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, 2009, 2010, 2011 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011, 2012 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1712,14 +1712,6 @@ leave it unspecified which argument's type is incorrect. Again, @code{SCM_ARGn} should be preferred over a raw zero constant. @end deftypefn -The @code{SCM_ASRTGO} macro provides another strategy for handling -incorrect types. - -@deftypefn Macro void SCM_ASRTGO (int @var{test}, label) -If @var{test} is zero, use @code{goto} to jump to the given @var{label}. -@var{label} must appear within the current function. -@end deftypefn - @node Continuation Barriers @subsection Continuation Barriers diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index afcde579d..9799c31d5 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1181,7 +1181,7 @@ procedures and does not rely on R6RS support. Some of the procedures described in this chapter accept a file name as an argument. Valid values for such a file name include strings that name a file -using the native notation of filesystem paths on an implementation's +using the native notation of file system paths on an implementation's underlying operating system, and may include implementation-dependent values as well. diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index 92816ad82..e60864ba3 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.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, 2009, 2010, 2011 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011, 2012 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -40,6 +40,7 @@ languages}, or EDSLs.}. * Syntax Case:: Procedural, hygienic macros. * Defmacros:: Lisp-style macros. * Identifier Macros:: Identifier macros. +* Syntax Parameters:: Syntax Parameters * Eval When:: Affecting the expand-time environment. * Internal Macros:: Macros as first-class values. @end menu @@ -861,6 +862,81 @@ wrapping in @code{#'} syntax forms. @end deffn +@node Syntax Parameters +@subsection Syntax Parameters + +Syntax parameters@footnote{Described in the paper @cite{Keeping it Clean +with Syntax Parameters} by Barzilay, Culpepper and Flatt.} are a +mechanism for rebinding a macro definition within the dynamic extent of +a macro expansion. This provides a convenient solution to one of the +most common types of unhygienic macro: those that introduce a unhygienic +binding each time the macro is used. Examples include a @code{lambda} +form with a @code{return} keyword, or class macros that introduce a +special @code{self} binding. + +With syntax parameters, instead of introducing the binding +unhygienically each time, we instead create one binding for the keyword, +which we can then adjust later when we want the keyword to have a +different meaning. As no new bindings are introduced, hygiene is +preserved. This is similar to the dynamic binding mechanisms we have at +run-time (@pxref{SRFI-39, parameters}), except that the dynamic binding +only occurs during macro expansion. The code after macro expansion +remains lexically scoped. + +@deffn {Syntax} define-syntax-parameter keyword transformer +Binds @var{keyword} to the value obtained by evaluating +@var{transformer}. The @var{transformer} provides the default expansion +for the syntax parameter, and in the absence of +@code{syntax-parameterize}, is functionally equivalent to +@code{define-syntax}. Usually, you will just want to have the +@var{transformer} throw a syntax error indicating that the @var{keyword} +is supposed to be used in conjunction with another macro, for example: +@example +(define-syntax-parameter return + (lambda (stx) + (syntax-violation 'return "return used outside of a lambda^" stx))) +@end example +@end deffn + +@deffn {Syntax} syntax-parameterize ((keyword transformer) @dots{}) exp @dots{} +Adjusts @var{keyword} @dots{} to use the values obtained by evaluating +their @var{transformer} @dots{}, in the expansion of the @var{exp} +@dots{} forms. Each @var{keyword} must be bound to a syntax-parameter. +@code{syntax-parameterize} differs from @code{let-syntax}, in that the +binding is not shadowed, but adjusted, and so uses of the keyword in the +expansion of @var{exp} @dots{} use the new transformers. This is +somewhat similar to how @code{parameterize} adjusts the values of +regular parameters, rather than creating new bindings. + +@example +(define-syntax lambda^ + (syntax-rules () + [(lambda^ argument-list body body* ...) + (lambda argument-list + (call-with-current-continuation + (lambda (escape) + ;; In the body we adjust the 'return' keyword so that calls + ;; to 'return' are replaced with calls to the escape + ;; continuation. + (syntax-parameterize ([return (syntax-rules () + [(return vals (... ...)) + (escape vals (... ...))])]) + body body* ...))))])) + +;; Now we can write functions that return early. Here, 'product' will +;; return immediately if it sees any 0 element. +(define product + (lambda^ (list) + (fold (lambda (n o) + (if (zero? n) + (return 0) + (* n o))) + 1 + list))) +@end example +@end deffn + + @node Eval When @subsection Eval-when diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 33c9819e4..9830cfd53 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-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, 2007, 2008, 2009, 2010, 2011 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, 2009, 2010, 2011, 2012 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -44,12 +44,13 @@ be used for interacting with the module system. * General Information about Modules:: Guile module basics. * Using Guile Modules:: How to use existing modules. * Creating Guile Modules:: How to package your code into modules. -* Module System Reflection:: Accessing module objects at run-time. -* Included Guile Modules:: Which modules come with Guile? +* Modules and the File System:: Installing modules in the file system. * R6RS Version References:: Using version numbers with modules. * R6RS Libraries:: The library and import forms. -* Accessing Modules from C:: How to work with modules with C code. * Variables:: First-class variables. +* Module System Reflection:: First-class modules. +* Accessing Modules from C:: How to work with modules with C code. +* Included Guile Modules:: Which modules come with Guile? * provide and require:: The SLIB feature mechanism. * Environments:: R5RS top-level environments. @end menu @@ -61,12 +62,6 @@ A Guile module can be thought of as a collection of named procedures, variables and macros. More precisely, it is a set of @dfn{bindings} of symbols (names) to Scheme objects. -An environment is a mapping from identifiers (or symbols) to locations, -i.e., a set of bindings. -There are top-level environments and lexical environments. -The environment in which a lambda is executed is remembered as part of its -definition. - Within a module, all bindings are visible. Certain bindings can be declared @dfn{public}, in which case they are added to the module's so-called @dfn{export list}; this set of public bindings is @@ -81,42 +76,18 @@ algorithmically @dfn{rename} bindings. In contrast, when using the providing module's public interface, the entire export list is available without renaming (@pxref{Using Guile Modules}). -To use a module, it must be found and loaded. All Guile modules have a -unique @dfn{module name}, which is a list of one or more symbols. -Examples are @code{(ice-9 popen)} or @code{(srfi srfi-11)}. When Guile -searches for the code of a module, it constructs the name of the file to -load by concatenating the name elements with slashes between the -elements and appending a number of file name extensions from the list -@code{%load-extensions} (@pxref{Loading}). The resulting file name is -then searched in all directories in the variable @code{%load-path} -(@pxref{Build Config}). For example, the @code{(ice-9 popen)} module -would result in the filename @code{ice-9/popen.scm} and searched in the -installation directories of Guile and in all other directories in the -load path. - -A slightly different search mechanism is used when a client module -specifies a version reference as part of a request to load a module -(@pxref{R6RS Version References}). Instead of searching the directories -in the load path for a single filename, Guile uses the elements of the -version reference to locate matching, numbered subdirectories of a -constructed base path. For example, a request for the -@code{(rnrs base)} module with version reference @code{(6)} would cause -Guile to discover the @code{rnrs/6} subdirectory (if it exists in any of -the directories in the load path) and search its contents for the -filename @code{base.scm}. - -When multiple modules are found that match a version reference, Guile -sorts these modules by version number, followed by the length of their -version specifications, in order to choose a ``best'' match. - -@c FIXME::martin: Not sure about this, maybe someone knows better? -Every module has a so-called syntax transformer associated with it. -This is a procedure which performs all syntax transformation for the -time the module is read in and evaluated. When working with modules, -you can manipulate the current syntax transformer using the -@code{use-syntax} syntactic form or the @code{#:use-syntax} module -definition option (@pxref{Creating Guile Modules}). +All Guile modules have a unique @dfn{module name}, for example +@code{(ice-9 popen)} or @code{(srfi srfi-11)}. Module names are lists +of one or more symbols. + +When Guile goes to use an interface from a module, for example +@code{(ice-9 popen)}, Guile first looks to see if it has loaded +@code{(ice-9 popen)} for any reason. If the module has not been loaded +yet, Guile searches a @dfn{load path} for a file that might define it, +and loads that file. +The following subsections go into more detail on using, creating, +installing, and otherwise manipulating modules and the module system. @node Using Guile Modules @subsection Using Guile Modules @@ -198,14 +169,11 @@ has not yet been loaded yet will be loaded when referenced by a You can also use the @code{@@} and @code{@@@@} syntaxes as the target of a @code{set!} when the binding refers to a variable. -@c begin (scm-doc-string "boot-9.scm" "symbol-prefix-proc") @deffn {Scheme Procedure} symbol-prefix-proc prefix-sym Return a procedure that prefixes its arg (a symbol) with @var{prefix-sym}. -@c Insert gratuitous C++ slam here. --ttn @end deffn -@c begin (scm-doc-string "boot-9.scm" "use-modules") @deffn syntax use-modules spec @dots{} Resolve each interface specification @var{spec} into an interface and arrange for these to be accessible by the current module. The return @@ -218,7 +186,7 @@ whose public interface is found and used. @cindex binding renamer @lisp - (MODULE-NAME [:select SELECTION] [:renamer RENAMER]) + (MODULE-NAME [#:select SELECTION] [#:renamer RENAMER]) @end lisp in which case a custom interface is newly created and used. @@ -229,37 +197,26 @@ a pair of symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in the used module and @var{seen} is the name in the using module. Note that @var{seen} is also passed through @var{renamer}. -The @code{:select} and @code{:renamer} clauses are optional. If both are -omitted, the returned interface has no bindings. If the @code{:select} +The @code{#:select} and @code{#:renamer} clauses are optional. If both are +omitted, the returned interface has no bindings. If the @code{#:select} clause is omitted, @var{renamer} operates on the used module's public interface. -In addition to the above, @var{spec} can also include a @code{:version} +In addition to the above, @var{spec} can also include a @code{#:version} clause, of the form: @lisp - :version VERSION-SPEC + #:version VERSION-SPEC @end lisp -where @var{version-spec} is an R6RS-compatible version reference. The -presence of this clause changes Guile's search behavior as described in -the section on module name resolution -(@pxref{General Information about Modules}). An error will be signaled -in the case in which a module with the same name has already been -loaded, if that module specifies a version and that version is not -compatible with @var{version-spec}. - -Signal error if module name is not resolvable. -@end deffn - - -@c FIXME::martin: Is this correct, and is there more to say? -@c FIXME::martin: Define term and concept `syntax transformer' somewhere. +where @var{version-spec} is an R6RS-compatible version reference. An +error will be signaled in the case in which a module with the same name +has already been loaded, if that module specifies a version and that +version is not compatible with @var{version-spec}. @xref{R6RS Version +References}, for more on version references. -@deffn syntax use-syntax module-name -Load the module @code{module-name} and use its syntax -transformer as the syntax transformer for the currently defined module, -as well as installing it as the current syntax transformer. +If the module name is not resolvable, @code{use-modules} will signal an +error. @end deffn @deffn syntax @@ module-name binding-name @@ -293,10 +250,8 @@ Export all bindings which should be in the public interface, either by using @code{define-public} or @code{export} (both documented below). @end itemize -@c begin (scm-doc-string "boot-9.scm" "define-module") @deffn syntax define-module module-name [options @dots{}] -@var{module-name} is of the form @code{(hierarchy file)}. One -example of this is +@var{module-name} is a list of one or more symbols. @lisp (define-module (ice-9 popen)) @@ -309,17 +264,11 @@ The @var{options} are keyword/value pairs which specify more about the defined module. The recognized options and their meaning is shown in the following table. -@c fixme: Should we use "#:" or ":"? - @table @code @item #:use-module @var{interface-specification} Equivalent to a @code{(use-modules @var{interface-specification})} (@pxref{Using Guile Modules}). -@item #:use-syntax @var{module} -Use @var{module} when loading the currently defined module, and install -it as the syntax transformer. - @item #:autoload @var{module} @var{symbol-list} @cindex autoload Load @var{module} when any of @var{symbol-list} are accessed. For @@ -347,7 +296,7 @@ the module is used. @item #:export @var{list} @cindex export Export all identifiers in @var{list} which must be a list of symbols -or pairs of symbols. This is equivalent to @code{(export @var{list})} +or pairs of symbols. This is equivalent to @code{(export @var{list})} in the module body. @item #:re-export @var{list} @@ -357,20 +306,6 @@ symbols or pairs of symbols. The symbols in @var{list} must be imported by the current module from other modules. This is equivalent to @code{re-export} below. -@item #:export-syntax @var{list} -@cindex export-syntax -Export all identifiers in @var{list} which must be a list of symbols -or pairs of symbols. The identifiers in @var{list} must refer to -macros (@pxref{Macros}) defined in the current module. This is -equivalent to @code{(export-syntax @var{list})} in the module body. - -@item #:re-export-syntax @var{list} -@cindex re-export-syntax -Re-export all identifiers in @var{list} which must be a list of -symbols or pairs of symbols. The symbols in @var{list} must refer to -macros imported by the current module from other modules. This is -equivalent to @code{(re-export-syntax @var{list})} in the module body. - @item #:replace @var{list} @cindex replace @cindex replacing binding @@ -400,6 +335,9 @@ function (@pxref{Time}). Guile assumes that a user importing a module knows what she is doing, and uses @code{#:replace} for this binding rather than @code{#:export}. +A @code{#:replace} clause is equivalent to @code{(export! @var{list})} +in the module body. + The @code{#:duplicates} (see below) provides fine-grain control about duplicate binding handling on the module-user side. @@ -464,6 +402,10 @@ a duplicate binding situation. As mentioned above, some resolution policies may explicitly leave the responsibility of handling the duplication to the next handler in @var{list}. +If GOOPS has been loaded before the @code{#:duplicates} clause is +processed, there are additional strategies available for dealing with +generic functions. @xref{Merging Generics}, for more information. + @findex default-duplicate-binding-handler The default duplicate binding resolution policy is given by the @code{default-duplicate-binding-handler} procedure, and is @@ -472,11 +414,6 @@ The default duplicate binding resolution policy is given by the (replace warn-override-core warn last) @end lisp -@item #:no-backtrace -@cindex no backtrace -Tell Guile not to record information for procedure backtraces when -executing the procedures in this module. - @item #:pure @cindex pure module Create a @dfn{pure} module, that is a module which does not contain any @@ -486,7 +423,6 @@ do not know anything about dangerous procedures. @end table @end deffn -@c end @deffn syntax export variable @dots{} Add all @var{variable}s (which must be symbols or pairs of symbols) to @@ -496,11 +432,9 @@ current module and its @code{cdr} specifies a name for the binding in the current module's public interface. @end deffn -@c begin (scm-doc-string "boot-9.scm" "define-public") @deffn syntax define-public @dots{} Equivalent to @code{(begin (define foo ...) (export foo))}. @end deffn -@c end @deffn syntax re-export variable @dots{} Add all @var{variable}s (which must be symbols or pairs of symbols) to @@ -509,184 +443,47 @@ symbols are handled as in @code{export}. Re-exported bindings must be imported by the current module from some other module. @end deffn -@node Module System Reflection -@subsection Module System Reflection - -The previous sections have described a declarative view of the module -system. You can also work with it programmatically by accessing and -modifying various parts of the Scheme objects that Guile uses to -implement the module system. - -At any time, there is a @dfn{current module}. This module is the one -where a top-level @code{define} and similar syntax will add new -bindings. You can find other module objects with @code{resolve-module}, -for example. - -These module objects can be used as the second argument to @code{eval}. - -@deffn {Scheme Procedure} current-module -Return the current module object. -@end deffn - -@deffn {Scheme Procedure} set-current-module module -Set the current module to @var{module} and return -the previous current module. -@end deffn - -@deffn {Scheme Procedure} save-module-excursion thunk -Call @var{thunk} within a @code{dynamic-wind} such that the module that -is current at invocation time is restored when @var{thunk}'s dynamic -extent is left (@pxref{Dynamic Wind}). - -More precisely, if @var{thunk} escapes non-locally, the current module -(at the time of escape) is saved, and the original current module (at -the time @var{thunk}'s dynamic extent was last entered) is restored. If -@var{thunk}'s dynamic extent is re-entered, then the current module is -saved, and the previously saved inner module is set current again. -@end deffn - -@deffn {Scheme Procedure} resolve-module name -Find the module named @var{name} and return it. When it has not already -been defined, try to auto-load it. When it can't be found that way -either, create an empty module. The name is a list of symbols. -@end deffn - -@deffn {Scheme Procedure} resolve-interface name -Find the module named @var{name} as with @code{resolve-module} and -return its interface. The interface of a module is also a module -object, but it contains only the exported bindings. +@deffn syntax export! variable @dots{} +Like @code{export}, but marking the exported variables as replacing. +Using a module with replacing bindings will cause any existing bindings +to be replaced without issuing any warnings. See the discussion of +@code{#:replace} above. @end deffn -@deffn {Scheme Procedure} module-use! module interface -Add @var{interface} to the front of the use-list of @var{module}. Both -arguments should be module objects, and @var{interface} should very -likely be a module returned by @code{resolve-interface}. -@end deffn - -@deffn {Scheme Procedure} reload-module module -Revisit the source file that corresponds to @var{module}. Raises an -error if no source file is associated with the given module. -@end deffn - - -@node Included Guile Modules -@subsection Included Guile Modules - -@c FIXME::martin: Review me! - -Some modules are included in the Guile distribution; here are references -to the entries in this manual which describe them in more detail: - -@table @strong -@item boot-9 -boot-9 is Guile's initialization module, and it is always loaded when -Guile starts up. - -@item (ice-9 expect) -Actions based on matching input from a port (@pxref{Expect}). - -@item (ice-9 format) -Formatted output in the style of Common Lisp (@pxref{Formatted -Output}). - -@item (ice-9 ftw) -File tree walker (@pxref{File Tree Walk}). - -@item (ice-9 getopt-long) -Command line option processing (@pxref{getopt-long}). - -@item (ice-9 history) -Refer to previous interactive expressions (@pxref{Value History}). - -@item (ice-9 popen) -Pipes to and from child processes (@pxref{Pipes}). - -@item (ice-9 pretty-print) -Nicely formatted output of Scheme expressions and objects -(@pxref{Pretty Printing}). - -@item (ice-9 q) -First-in first-out queues (@pxref{Queues}). - -@item (ice-9 rdelim) -Line- and character-delimited input (@pxref{Line/Delimited}). - -@item (ice-9 readline) -@code{readline} interactive command line editing (@pxref{Readline -Support}). - -@item (ice-9 receive) -Multiple-value handling with @code{receive} (@pxref{Multiple Values}). - -@item (ice-9 regex) -Regular expression matching (@pxref{Regular Expressions}). - -@item (ice-9 rw) -Block string input/output (@pxref{Block Reading and Writing}). - -@item (ice-9 streams) -Sequence of values calculated on-demand (@pxref{Streams}). - -@item (ice-9 syncase) -R5RS @code{syntax-rules} macro system (@pxref{Syntax Rules}). - -@item (ice-9 threads) -Guile's support for multi threaded execution (@pxref{Scheduling}). - -@item (ice-9 documentation) -Online documentation (REFFIXME). - -@item (srfi srfi-1) -A library providing a lot of useful list and pair processing -procedures (@pxref{SRFI-1}). - -@item (srfi srfi-2) -Support for @code{and-let*} (@pxref{SRFI-2}). - -@item (srfi srfi-4) -Support for homogeneous numeric vectors (@pxref{SRFI-4}). - -@item (srfi srfi-6) -Support for some additional string port procedures (@pxref{SRFI-6}). - -@item (srfi srfi-8) -Multiple-value handling with @code{receive} (@pxref{SRFI-8}). - -@item (srfi srfi-9) -Record definition with @code{define-record-type} (@pxref{SRFI-9}). - -@item (srfi srfi-10) -Read hash extension @code{#,()} (@pxref{SRFI-10}). - -@item (srfi srfi-11) -Multiple-value handling with @code{let-values} and @code{let*-values} -(@pxref{SRFI-11}). - -@item (srfi srfi-13) -String library (@pxref{SRFI-13}). - -@item (srfi srfi-14) -Character-set library (@pxref{SRFI-14}). +@node Modules and the File System +@subsection Modules and the File System -@item (srfi srfi-16) -@code{case-lambda} procedures of variable arity (@pxref{SRFI-16}). +Typical programs only use a small subset of modules installed on a Guile +system. In order to keep startup time down, Guile only loads modules +when a program uses them, on demand. -@item (srfi srfi-17) -Getter-with-setter support (@pxref{SRFI-17}). +When a program evaluates @code{(use-modules (ice-9 popen))}, and the +module is not loaded, Guile searches for a conventionally-named file +from in the @dfn{load path}. -@item (srfi srfi-19) -Time/Date library (@pxref{SRFI-19}). +In this case, loading @code{(ice-9 popen)} will eventually cause Guile +to run @code{(primitive-load-path "ice-9/popen")}. +@code{primitive-load-path} will search for a file @file{ice-9/popen} in +the @code{%load-path} (@pxref{Build Config}). For each directory in +@code{%load-path}, Guile will try to find the file name, concatenated +with the extensions from @code{%load-extensions}. By default, this will +cause Guile to @code{stat} @file{ice-9/popen.scm}, and then +@file{ice-9/popen}. @xref{Loading}, for more on +@code{primitive-load-path}. -@item (srfi srfi-26) -Convenient syntax for partial application (@pxref{SRFI-26}) +If a corresponding compiled @file{.go} file is found in the +@code{%load-compiled-path} or in the fallback path, and is as fresh as +the source file, it will be loaded instead of the source file. If no +compiled file is found, Guile may try to compile the source file and +cache away the resulting @file{.go} file. @xref{Compilation}, for more +on compilation. -@item (srfi srfi-31) -@code{rec} convenient recursive expressions (@pxref{SRFI-31}) +Once Guile finds a suitable source or compiled file is found, the file +will be loaded. If, after loading the file, the module under +consideration is still not defined, Guile will signal an error. -@item (ice-9 slib) -This module contains hooks for using Aubrey Jaffer's portable Scheme -library SLIB from Guile (@pxref{SLIB}). -@end table +For more information on where and how to install Scheme modules, +@xref{Installing Site Packages}. @node R6RS Version References @@ -910,6 +707,196 @@ same form as in the @code{library} form described above. @end deffn +@node Variables +@subsection Variables +@tpindex Variables + +Each module has its own hash table, sometimes known as an @dfn{obarray}, +that maps the names defined in that module to their corresponding +variable objects. + +A variable is a box-like object that can hold any Scheme value. It is +said to be @dfn{undefined} if its box holds a special Scheme value that +denotes undefined-ness (which is different from all other Scheme values, +including for example @code{#f}); otherwise the variable is +@dfn{defined}. + +On its own, a variable object is anonymous. A variable is said to be +@dfn{bound} when it is associated with a name in some way, usually a +symbol in a module obarray. When this happens, the name is said to be +bound to the variable, in that module. + +(That's the theory, anyway. In practice, defined-ness and bound-ness +sometimes get confused, because Lisp and Scheme implementations have +often conflated --- or deliberately drawn no distinction between --- a +name that is unbound and a name that is bound to a variable whose value +is undefined. We will try to be clear about the difference and explain +any confusion where it is unavoidable.) + +Variables do not have a read syntax. Most commonly they are created and +bound implicitly by @code{define} expressions: a top-level @code{define} +expression of the form + +@lisp +(define @var{name} @var{value}) +@end lisp + +@noindent +creates a variable with initial value @var{value} and binds it to the +name @var{name} in the current module. But they can also be created +dynamically by calling one of the constructor procedures +@code{make-variable} and @code{make-undefined-variable}. + +@deffn {Scheme Procedure} make-undefined-variable +@deffnx {C Function} scm_make_undefined_variable () +Return a variable that is initially unbound. +@end deffn + +@deffn {Scheme Procedure} make-variable init +@deffnx {C Function} scm_make_variable (init) +Return a variable initialized to value @var{init}. +@end deffn + +@deffn {Scheme Procedure} variable-bound? var +@deffnx {C Function} scm_variable_bound_p (var) +Return @code{#t} iff @var{var} is bound to a value. +Throws an error if @var{var} is not a variable object. +@end deffn + +@deffn {Scheme Procedure} variable-ref var +@deffnx {C Function} scm_variable_ref (var) +Dereference @var{var} and return its value. +@var{var} must be a variable object; see @code{make-variable} +and @code{make-undefined-variable}. +@end deffn + +@deffn {Scheme Procedure} variable-set! var val +@deffnx {C Function} scm_variable_set_x (var, val) +Set the value of the variable @var{var} to @var{val}. +@var{var} must be a variable object, @var{val} can be any +value. Return an unspecified value. +@end deffn + +@deffn {Scheme Procedure} variable-unset! var +@deffnx {C Function} scm_variable_unset_x (var) +Unset the value of the variable @var{var}, leaving @var{var} unbound. +@end deffn + +@deffn {Scheme Procedure} variable? obj +@deffnx {C Function} scm_variable_p (obj) +Return @code{#t} iff @var{obj} is a variable object, else +return @code{#f}. +@end deffn + + +@node Module System Reflection +@subsection Module System Reflection + +The previous sections have described a declarative view of the module +system. You can also work with it programmatically by accessing and +modifying various parts of the Scheme objects that Guile uses to +implement the module system. + +At any time, there is a @dfn{current module}. This module is the one +where a top-level @code{define} and similar syntax will add new +bindings. You can find other module objects with @code{resolve-module}, +for example. + +These module objects can be used as the second argument to @code{eval}. + +@deffn {Scheme Procedure} current-module +@deffnx {C Function} scm_current_module () +Return the current module object. +@end deffn + +@deffn {Scheme Procedure} set-current-module module +@deffnx {C Function} scm_set_current_module (module) +Set the current module to @var{module} and return +the previous current module. +@end deffn + +@deffn {Scheme Procedure} save-module-excursion thunk +Call @var{thunk} within a @code{dynamic-wind} such that the module that +is current at invocation time is restored when @var{thunk}'s dynamic +extent is left (@pxref{Dynamic Wind}). + +More precisely, if @var{thunk} escapes non-locally, the current module +(at the time of escape) is saved, and the original current module (at +the time @var{thunk}'s dynamic extent was last entered) is restored. If +@var{thunk}'s dynamic extent is re-entered, then the current module is +saved, and the previously saved inner module is set current again. +@end deffn + +@deffn {Scheme Procedure} resolve-module name [autoload=#t] [version=#f] [#:ensure=#t] +@deffnx {C Function} scm_resolve_module (name) +Find the module named @var{name} and return it. When it has not already +been defined and @var{autoload} is true, try to auto-load it. When it +can't be found that way either, create an empty module if @var{ensure} +is true, otherwise return @code{#f}. If @var{version} is true, ensure +that the resulting module is compatible with the given version reference +(@pxref{R6RS Version References}). The name is a list of symbols. +@end deffn + +@deffn {Scheme Procedure} resolve-interface name [#:select=#f] [#:hide='()] [#:select=()] [#:prefix=#f] [#:renamer] [#:version=#f] +Find the module named @var{name} as with @code{resolve-module} and +return its interface. The interface of a module is also a module +object, but it contains only the exported bindings. +@end deffn + +@deffn {Scheme Procedure} module-uses module +Return a list of the interfaces used by @var{module}. +@end deffn + +@deffn {Scheme Procedure} module-use! module interface +Add @var{interface} to the front of the use-list of @var{module}. Both +arguments should be module objects, and @var{interface} should very +likely be a module returned by @code{resolve-interface}. +@end deffn + +@deffn {Scheme Procedure} reload-module module +Revisit the source file that corresponds to @var{module}. Raises an +error if no source file is associated with the given module. +@end deffn + +As mentioned in the previous section, modules contain a mapping between +identifiers (as symbols) and storage locations (as variables). Guile +defines a number of procedures to allow access to this mapping. If you +are programming in C, @ref{Accessing Modules from C}. + +@deffn {Scheme Procedure} module-variable module name +Return the variable bound to @var{name} (a symbol) in @var{module}, or +@code{#f} if @var{name} is unbound. +@end deffn + +@deffn {Scheme Procedure} module-add! module name var +Define a new binding between @var{name} (a symbol) and @var{var} (a +variable) in @var{module}. +@end deffn + +@deffn {Scheme Procedure} module-ref module name +Look up the value bound to @var{name} in @var{module}. Like +@code{module-variable}, but also does a @code{variable-ref} on the +resulting variable, raising an error if @var{name} is unbound. +@end deffn + +@deffn {Scheme Procedure} module-define! module name value +Locally bind @var{name} to @var{value} in @var{module}. If @var{name} +was already locally bound in @var{module}, i.e., defined locally and not +by an imported module, the value stored in the existing variable will be +updated. Otherwise, a new variable will be added to the module, via +@code{module-add!}. +@end deffn + +@deffn {Scheme Procedure} module-set! module name value +Update the binding of @var{name} in @var{module} to @var{value}, raising +an error if @var{name} is not already bound in @var{module}. +@end deffn + +There are many other reflective procedures available in the default +environment. If you find yourself using one of them, please contact the +Guile developers so that we can commit to stability for that interface. + + @node Accessing Modules from C @subsection Accessing Modules from C @@ -919,15 +906,6 @@ can also work with modules from C, but it is more cumbersome. The following procedures are available. -@deftypefn {C Function} SCM scm_current_module () -Return the module that is the @emph{current module}. -@end deftypefn - -@deftypefn {C Function} SCM scm_set_current_module (SCM @var{module}) -Set the current module to @var{module} and return the previous current -module. -@end deftypefn - @deftypefn {C Function} SCM scm_c_call_with_current_module (SCM @var{module}, SCM (*@var{func})(void *), void *@var{data}) Call @var{func} and make @var{module} the current module during the call. The argument @var{data} is passed to @var{func}. The return @@ -1053,11 +1031,6 @@ that way either, create an empty module. The name is interpreted as for @code{scm_c_define_module}. @end deftypefn -@deftypefn {C Function} SCM scm_resolve_module (SCM @var{name}) -Like @code{scm_c_resolve_module}, but the name is given as a real list -of symbols. -@end deftypefn - @deftypefn {C Function} SCM scm_c_use_module ({const char *}@var{name}) Add the module named @var{name} to the uses list of the current module, as with @code{(use-modules @var{name})}. The name is @@ -1071,87 +1044,122 @@ of the current module. The list of names is terminated by @end deftypefn -@node Variables -@subsection Variables -@tpindex Variables +@node Included Guile Modules +@subsection Included Guile Modules -Each module has its own hash table, sometimes known as an @dfn{obarray}, -that maps the names defined in that module to their corresponding -variable objects. +Some modules are included in the Guile distribution; here are references +to the entries in this manual which describe them in more detail: -A variable is a box-like object that can hold any Scheme value. It is -said to be @dfn{undefined} if its box holds a special Scheme value that -denotes undefined-ness (which is different from all other Scheme values, -including for example @code{#f}); otherwise the variable is -@dfn{defined}. +@table @strong +@item boot-9 +boot-9 is Guile's initialization module, and it is always loaded when +Guile starts up. -On its own, a variable object is anonymous. A variable is said to be -@dfn{bound} when it is associated with a name in some way, usually a -symbol in a module obarray. When this happens, the relationship is -mutual: the variable is bound to the name (in that module), and the name -(in that module) is bound to the variable. +@item (ice-9 expect) +Actions based on matching input from a port (@pxref{Expect}). -(That's the theory, anyway. In practice, defined-ness and bound-ness -sometimes get confused, because Lisp and Scheme implementations have -often conflated --- or deliberately drawn no distinction between --- a -name that is unbound and a name that is bound to a variable whose value -is undefined. We will try to be clear about the difference and explain -any confusion where it is unavoidable.) +@item (ice-9 format) +Formatted output in the style of Common Lisp (@pxref{Formatted +Output}). -Variables do not have a read syntax. Most commonly they are created and -bound implicitly by @code{define} expressions: a top-level @code{define} -expression of the form +@item (ice-9 ftw) +File tree walker (@pxref{File Tree Walk}). -@lisp -(define @var{name} @var{value}) -@end lisp +@item (ice-9 getopt-long) +Command line option processing (@pxref{getopt-long}). -@noindent -creates a variable with initial value @var{value} and binds it to the -name @var{name} in the current module. But they can also be created -dynamically by calling one of the constructor procedures -@code{make-variable} and @code{make-undefined-variable}. +@item (ice-9 history) +Refer to previous interactive expressions (@pxref{Value History}). -@deffn {Scheme Procedure} make-undefined-variable -@deffnx {C Function} scm_make_undefined_variable () -Return a variable that is initially unbound. -@end deffn +@item (ice-9 popen) +Pipes to and from child processes (@pxref{Pipes}). -@deffn {Scheme Procedure} make-variable init -@deffnx {C Function} scm_make_variable (init) -Return a variable initialized to value @var{init}. -@end deffn +@item (ice-9 pretty-print) +Nicely formatted output of Scheme expressions and objects +(@pxref{Pretty Printing}). -@deffn {Scheme Procedure} variable-bound? var -@deffnx {C Function} scm_variable_bound_p (var) -Return @code{#t} iff @var{var} is bound to a value. -Throws an error if @var{var} is not a variable object. -@end deffn +@item (ice-9 q) +First-in first-out queues (@pxref{Queues}). -@deffn {Scheme Procedure} variable-ref var -@deffnx {C Function} scm_variable_ref (var) -Dereference @var{var} and return its value. -@var{var} must be a variable object; see @code{make-variable} -and @code{make-undefined-variable}. -@end deffn +@item (ice-9 rdelim) +Line- and character-delimited input (@pxref{Line/Delimited}). -@deffn {Scheme Procedure} variable-set! var val -@deffnx {C Function} scm_variable_set_x (var, val) -Set the value of the variable @var{var} to @var{val}. -@var{var} must be a variable object, @var{val} can be any -value. Return an unspecified value. -@end deffn +@item (ice-9 readline) +@code{readline} interactive command line editing (@pxref{Readline +Support}). -@deffn {Scheme Procedure} variable-unset! var -@deffnx {C Function} scm_variable_unset_x (var) -Unset the value of the variable @var{var}, leaving @var{var} unbound. -@end deffn +@item (ice-9 receive) +Multiple-value handling with @code{receive} (@pxref{Multiple Values}). -@deffn {Scheme Procedure} variable? obj -@deffnx {C Function} scm_variable_p (obj) -Return @code{#t} iff @var{obj} is a variable object, else -return @code{#f}. -@end deffn +@item (ice-9 regex) +Regular expression matching (@pxref{Regular Expressions}). + +@item (ice-9 rw) +Block string input/output (@pxref{Block Reading and Writing}). + +@item (ice-9 streams) +Sequence of values calculated on-demand (@pxref{Streams}). + +@item (ice-9 syncase) +R5RS @code{syntax-rules} macro system (@pxref{Syntax Rules}). + +@item (ice-9 threads) +Guile's support for multi threaded execution (@pxref{Scheduling}). + +@item (ice-9 documentation) +Online documentation (REFFIXME). + +@item (srfi srfi-1) +A library providing a lot of useful list and pair processing +procedures (@pxref{SRFI-1}). + +@item (srfi srfi-2) +Support for @code{and-let*} (@pxref{SRFI-2}). + +@item (srfi srfi-4) +Support for homogeneous numeric vectors (@pxref{SRFI-4}). + +@item (srfi srfi-6) +Support for some additional string port procedures (@pxref{SRFI-6}). + +@item (srfi srfi-8) +Multiple-value handling with @code{receive} (@pxref{SRFI-8}). + +@item (srfi srfi-9) +Record definition with @code{define-record-type} (@pxref{SRFI-9}). + +@item (srfi srfi-10) +Read hash extension @code{#,()} (@pxref{SRFI-10}). + +@item (srfi srfi-11) +Multiple-value handling with @code{let-values} and @code{let*-values} +(@pxref{SRFI-11}). + +@item (srfi srfi-13) +String library (@pxref{SRFI-13}). + +@item (srfi srfi-14) +Character-set library (@pxref{SRFI-14}). + +@item (srfi srfi-16) +@code{case-lambda} procedures of variable arity (@pxref{SRFI-16}). + +@item (srfi srfi-17) +Getter-with-setter support (@pxref{SRFI-17}). + +@item (srfi srfi-19) +Time/Date library (@pxref{SRFI-19}). + +@item (srfi srfi-26) +Convenient syntax for partial application (@pxref{SRFI-26}) + +@item (srfi srfi-31) +@code{rec} convenient recursive expressions (@pxref{SRFI-31}) + +@item (ice-9 slib) +This module contains hooks for using Aubrey Jaffer's portable Scheme +library SLIB from Guile (@pxref{SLIB}). +@end table @node provide and require diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index f1861a54a..2b4a05e08 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, +@c 2011, 2012 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Procedures @@ -838,7 +838,7 @@ demonstrably improves performance in a crucial way. In general, only small procedures should be considered for inlining, as making large procedures inlinable will probably result in an increase in code size. Additionally, the elimination of the call overhead rarely -matters for for large procedures. +matters for large procedures. @deffn {Scheme Syntax} define-inlinable (name parameter ...) body ... Define @var{name} as a procedure with parameters @var{parameter}s and diff --git a/doc/ref/libguile-snarf.texi b/doc/ref/libguile-snarf.texi index b295270a1..c70727f2d 100644 --- a/doc/ref/libguile-snarf.texi +++ b/doc/ref/libguile-snarf.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 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2012 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -82,10 +82,10 @@ The @code{SCM_DEFINE} declaration says that the C function rest argument. The string @code{"Clear the image."} provides a short help text for the function, it is called a @dfn{docstring}. -For historical reasons, the @code{SCM_DEFINE} macro also defines a -static array of characters named @code{s_clear_image}, initialized to -the string "clear-image". You shouldn't use this array, but you might -need to be aware that it exists. +@code{SCM_DEFINE} macro also defines a static array of characters +initialized to the Scheme name of the function. In this case, +@code{s_clear_image} is set to the C string, "clear-image". You might +want to use this symbol when generating error messages. Assuming the text above lives in a file named @file{image-type.c}, you will need to execute the following command to prepare this file for diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index 532203421..00354ac73 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2009, 2010, 2011 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2009, +@c 2010, 2011, 2012 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Pretty Printing @@ -1180,7 +1180,7 @@ than building up a tree of entries in memory, like directly as a directory tree is traversed; in fact, @code{file-system-tree} is implemented in terms of it. -@deffn {Scheme Procedure} file-system-fold enter? leaf down up skip init file-name [stat] +@deffn {Scheme Procedure} file-system-fold enter? leaf down up skip error init file-name [stat] Traverse the directory at @var{file-name}, recursively, and return the result of the successive applications of the @var{leaf}, @var{down}, @var{up}, and @var{skip} procedures as described below. @@ -1202,6 +1202,12 @@ encountered, call @code{(@var{skip} @var{path} @var{stat} When @var{file-name} names a flat file, @code{(@var{leaf} @var{path} @var{stat} @var{init})} is returned. +When an @code{opendir} or @var{stat} call fails, call @code{(@var{error} +@var{path} @var{stat} @var{errno} @var{result})}, with @var{errno} being +the operating system error number that was raised---e.g., +@code{EACCES}---and @var{stat} either @code{#f} or the result of the +@var{stat} call for that entry, when available. + The special @file{.} and @file{..} entries are not passed to these procedures. The @var{path} argument to the procedures is a full file name---e.g., @code{"../foo/bar/gnu"}; if @var{file-name} is an absolute @@ -1235,7 +1241,13 @@ to `du --apparent-size' with GNU Coreutils.)" ;; Likewise for skipped directories. (define (skip name stat result) result) - (file-system-fold enter? leaf down up skip + ;; Ignore unreadable files/directories but warn the user. + (define (error name stat errno result) + (format (current-error-port) "warning: ~a: ~a~%" + name (strerror errno)) + result) + + (file-system-fold enter? leaf down up skip error 0 ; initial counter is zero bytes file-name)) diff --git a/doc/sources/env.texi b/doc/sources/env.texi index a3efce2e2..7a37b768b 100644 --- a/doc/sources/env.texi +++ b/doc/sources/env.texi @@ -21,7 +21,7 @@ [[add refs for all conditions signalled]] @ifinfo -Copyright 1999, 2006 Free Software Foundation, Inc. +Copyright 1999, 2006, 2012 Free Software Foundation, Inc. @end ifinfo @titlepage @@ -204,7 +204,7 @@ can implement any module system you like, as long as its efforts produce an environment object the interpreter can consult. Finally, environments may prove a convenient way for Guile to access the -features of other systems. For example, one might export the The GIMP's +features of other systems. For example, one might export The GIMP's Procedural Database to Guile as a custom environment type; this environment could create Scheme procedure objects corresponding to GIMP procedures, as the user referenced them. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 502ae56fa..52ffc34be 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -62,7 +62,7 @@ gen-scmconfig.$(OBJEXT): gen-scmconfig.c $(AM_V_GEN) \ if [ "$(cross_compiling)" = "yes" ]; then \ $(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) -I$(top_builddir) \ - -c -o $@ $<; \ + -c -o $@ $<; \ else \ $(COMPILE) -c -o $@ $<; \ fi diff --git a/libguile/__scm.h b/libguile/__scm.h index ee73855c6..d0a421371 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -4,7 +4,7 @@ #define SCM___SCM_H /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2006, - * 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + * 2007, 2008, 2009, 2010, 2011, 2012 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 License diff --git a/libguile/array-map.c b/libguile/array-map.c index 395fa11a0..acd167da6 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2011, 2012 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 License @@ -892,7 +892,6 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, void scm_init_array_map (void) { - scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_array_equal_p; #include "libguile/array-map.x" scm_add_feature (s_scm_array_for_each); } diff --git a/libguile/arrays.c b/libguile/arrays.c index bcc351cb1..935d6f363 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -33,7 +33,6 @@ #include "libguile/chars.h" #include "libguile/eval.h" #include "libguile/fports.h" -#include "libguile/smob.h" #include "libguile/feature.h" #include "libguile/root.h" #include "libguile/strings.h" @@ -54,11 +53,10 @@ #include "libguile/uniform.h" -scm_t_bits scm_i_tc16_array; #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ - (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS)) + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ - (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS)) + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, @@ -111,14 +109,14 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, } #undef FUNC_NAME -SCM +SCM scm_i_make_array (int ndim) { SCM ra; - SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_i_tc16_array, - scm_gc_malloc ((sizeof (scm_i_t_array) + - ndim * sizeof (scm_t_array_dim)), - "array")); + ra = scm_cell (((scm_t_bits) ndim << 17) + scm_tc7_array, + (scm_t_bits) scm_gc_malloc (sizeof (scm_i_t_array) + + ndim * sizeof (scm_t_array_dim), + "array")); SCM_I_ARRAY_V (ra) = SCM_BOOL_F; return ra; } @@ -743,7 +741,7 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, /* Print an array. */ -static int +int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { scm_t_array_handle h; @@ -1015,18 +1013,14 @@ array_get_handle (SCM array, scm_t_array_handle *h) h->base = SCM_I_ARRAY_BASE (array); } -SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array), - SCM_SMOB_TYPE_MASK, +SCM_ARRAY_IMPLEMENTATION (scm_tc7_array, + 0x7f, array_handle_ref, array_handle_set, array_get_handle) void scm_init_arrays () { - scm_i_tc16_array = scm_make_smob_type ("array", 0); - scm_set_smob_print (scm_i_tc16_array, scm_i_print_array); - scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p); - scm_add_feature ("array"); #include "libguile/arrays.x" diff --git a/libguile/arrays.h b/libguile/arrays.h index 9b14d4e36..5ea604d6a 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -59,21 +59,20 @@ typedef struct scm_i_t_array unsigned long base; } scm_i_t_array; -SCM_INTERNAL scm_t_bits scm_i_tc16_array; - #define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) -#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a) -#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_SMOB_FLAGS (x)>>1)) -#define SCM_I_ARRAY_CONTP(x) (SCM_SMOB_FLAGS(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS) +#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a) +#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17)) +#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)) -#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_SMOB_DATA_1 (a)) +#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a)) #define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v) #define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base) #define SCM_I_ARRAY_DIMS(a) \ ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array))) SCM_INTERNAL SCM scm_i_make_array (int ndim); +SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate); SCM_INTERNAL SCM scm_i_read_array (SCM port, int c); SCM_INTERNAL void scm_init_arrays (void); diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 351e600a1..11a0cb1ee 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -144,6 +144,19 @@ SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0, { SCM_VALIDATE_OUTPUT_PORT (2, port); +#if SCM_ENABLE_DEPRECATED + if (SCM_STACKP (frame)) + { + scm_c_issue_deprecation_warning + ("Passing a stack as the first argument to `scm_display_error' is " + "deprecated. Pass a frame instead."); + if (SCM_STACK_LENGTH (frame)) + frame = scm_stack_ref (frame, SCM_INUM0); + else + frame = SCM_BOOL_F; + } +#endif + scm_i_display_error (frame, port, subr, message, args, rest); return SCM_UNSPECIFIED; diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 5b5a1b8e2..bc273a3b1 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012 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 License @@ -27,7 +27,6 @@ #include "libguile/_scm.h" #include "libguile/__scm.h" -#include "libguile/smob.h" #include "libguile/strings.h" #include "libguile/array-handle.h" #include "libguile/bitvectors.h" @@ -39,14 +38,12 @@ * but alack, all we have is this crufty C. */ -static scm_t_bits scm_tc16_bitvector; +#define IS_BITVECTOR(obj) SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj)) +#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_1(obj)) +#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_2(obj)) -#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj)) -#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj)) -#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj)) - -static int -bitvector_print (SCM vec, SCM port, scm_print_state *pstate) +int +scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) { size_t bit_len = BITVECTOR_LENGTH (vec); size_t word_len = (bit_len+31)/32; @@ -64,8 +61,8 @@ bitvector_print (SCM vec, SCM port, scm_print_state *pstate) return 1; } -static SCM -bitvector_equalp (SCM vec1, SCM vec2) +SCM +scm_i_bitvector_equal_p (SCM vec1, SCM vec2) { size_t bit_len = BITVECTOR_LENGTH (vec1); size_t word_len = (bit_len + 31) / 32; @@ -113,7 +110,7 @@ scm_c_make_bitvector (size_t len, SCM fill) bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len, "bitvector"); - SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len); + res = scm_double_cell (scm_tc7_bitvector, (scm_t_bits)bits, len, 0); if (!SCM_UNBNDP (fill)) scm_bitvector_fill_x (res, fill); @@ -145,7 +142,8 @@ SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1, size_t scm_c_bitvector_length (SCM vec) { - scm_assert_smob_type (scm_tc16_bitvector, vec); + if (!IS_BITVECTOR (vec)) + scm_wrong_type_arg_msg (NULL, 0, vec, "bitvector"); return BITVECTOR_LENGTH (vec); } @@ -880,8 +878,8 @@ bitvector_get_handle (SCM bv, scm_t_array_handle *h) h->elements = h->writable_elements = BITVECTOR_BITS (bv); } -SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_bitvector), - SCM_SMOB_TYPE_MASK, +SCM_ARRAY_IMPLEMENTATION (scm_tc7_bitvector, + 0x7f, bitvector_handle_ref, bitvector_handle_set, bitvector_get_handle) SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector) @@ -889,10 +887,6 @@ SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector) void scm_init_bitvectors () { - scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0); - scm_set_smob_print (scm_tc16_bitvector, bitvector_print); - scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp); - #include "libguile/bitvectors.x" } diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h index b6cf38357..6b25327a8 100644 --- a/libguile/bitvectors.h +++ b/libguile/bitvectors.h @@ -70,6 +70,8 @@ SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec, size_t *lenp, ssize_t *incp); +SCM_INTERNAL int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate); +SCM_INTERNAL SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2); SCM_INTERNAL void scm_init_bitvectors (void); #endif /* SCM_BITVECTORS_H */ diff --git a/libguile/eq.c b/libguile/eq.c index 5e270a25c..5a6f574d2 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -302,10 +302,6 @@ scm_equal_p (SCM x, SCM y) y = SCM_CDR(y); goto tailrecurse; } - if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string) - return scm_string_equal_p (x, y); - if (SCM_TYP7 (x) == scm_tc7_bytevector && SCM_TYP7 (y) == scm_tc7_bytevector) - return scm_bytevector_eq_p (x, y); if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y)) { int i = SCM_SMOBNUM (x); @@ -316,8 +312,6 @@ scm_equal_p (SCM x, SCM y) else goto generic_equal; } - if (SCM_POINTER_P (x) && SCM_POINTER_P (y)) - return scm_from_bool (SCM_POINTER_VALUE (x) == SCM_POINTER_VALUE (y)); /* This ensures that types and scm_length are the same. */ if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) @@ -352,7 +346,20 @@ scm_equal_p (SCM x, SCM y) return scm_complex_equalp (x, y); case scm_tc16_fraction: return scm_i_fraction_equalp (x, y); + default: + /* assert not reached? */ + return SCM_BOOL_F; } + case scm_tc7_pointer: + return scm_from_bool (SCM_POINTER_VALUE (x) == SCM_POINTER_VALUE (y)); + case scm_tc7_string: + return scm_string_equal_p (x, y); + case scm_tc7_bytevector: + return scm_bytevector_eq_p (x, y); + case scm_tc7_array: + return scm_array_equal_p (x, y); + case scm_tc7_bitvector: + return scm_i_bitvector_equal_p (x, y); case scm_tc7_vector: case scm_tc7_wvect: return scm_i_vector_equal_p (x, y); diff --git a/libguile/evalext.c b/libguile/evalext.c index 779c63d0a..3e04a7a59 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -89,6 +89,8 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_smob: case scm_tc7_program: case scm_tc7_bytevector: + case scm_tc7_array: + case scm_tc7_bitvector: case scm_tcs_struct: return SCM_BOOL_T; default: diff --git a/libguile/fports.c b/libguile/fports.c index 683c25bde..97dadded5 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -20,6 +20,7 @@ #define _LARGEFILE64_SOURCE /* ask for stat64 etc */ +#define _GNU_SOURCE /* ask for LONG_LONG_MAX/LONG_LONG_MIN */ #ifdef HAVE_CONFIG_H # include <config.h> diff --git a/libguile/goops.c b/libguile/goops.c index df1a64f7f..5e846eeae 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -160,6 +160,8 @@ static SCM class_vm; static SCM class_vm_cont; static SCM class_bytevector; static SCM class_uvec; +static SCM class_array; +static SCM class_bitvector; static SCM vtable_class_map = SCM_BOOL_F; @@ -275,6 +277,10 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_bytevector; else return class_uvec; + case scm_tc7_array: + return class_array; + case scm_tc7_bitvector: + return class_bitvector; case scm_tc7_string: return scm_class_string; case scm_tc7_number: @@ -2519,6 +2525,10 @@ create_standard_classes (void) scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_uvec, "<uvec>", scm_class_class, class_bytevector, SCM_EOL); + make_stdcls (&class_array, "<array>", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&class_bitvector, "<bitvector>", + scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_number, "<number>", scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_complex, "<complex>", diff --git a/libguile/i18n.c b/libguile/i18n.c index c0deb98d4..f833e5d16 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012 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 License @@ -196,22 +196,11 @@ typedef struct scm_locale int category_mask; } *scm_t_locale; - -/* Free the resources used by LOCALE. */ -static inline void -scm_i_locale_free (scm_t_locale locale) -{ - free (locale->locale_name); - locale->locale_name = NULL; -} - #else /* USE_GNU_LOCALE_API */ /* Alias for glibc's locale type. */ typedef locale_t scm_t_locale; -#define scm_i_locale_free freelocale - #endif /* USE_GNU_LOCALE_API */ @@ -244,16 +233,20 @@ SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale"); SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0); +#ifdef USE_GNU_LOCALE_API + SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) { scm_t_locale c_locale; c_locale = (scm_t_locale) SCM_SMOB_DATA (locale); - scm_i_locale_free (c_locale); + freelocale (c_locale); return 0; } +#endif /* USE_GNU_LOCALE_API */ + static void inline scm_locale_error (const char *, int) SCM_NORETURN; @@ -667,7 +660,8 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); c_locale->category_mask = c_category_mask; - c_locale->locale_name = c_locale_name; + c_locale->locale_name = scm_gc_strdup (c_locale_name, "locale"); + free (c_locale_name); if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale))) { diff --git a/libguile/load.c b/libguile/load.c index b28e30b2a..135a621cb 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -87,7 +87,9 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, #define FUNC_NAME s_scm_primitive_load { SCM hook = *scm_loc_load_hook; + SCM ret = SCM_UNSPECIFIED; char *encoding; + SCM_VALIDATE_STRING (1, filename); if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook))) SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f", @@ -96,8 +98,10 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, if (!scm_is_false (hook)) scm_call_1 (hook, filename); - { /* scope */ - SCM port = scm_open_file (filename, scm_from_locale_string ("r")); + { + SCM port; + + port = scm_open_file (filename, scm_from_locale_string ("r")); scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); scm_i_dynwind_current_load_port (port); @@ -124,13 +128,13 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, if (SCM_EOF_OBJECT_P (form)) break; - scm_primitive_eval_x (form); + ret = scm_primitive_eval_x (form); } scm_dynwind_end (); scm_close_port (port); } - return SCM_UNSPECIFIED; + return ret; } #undef FUNC_NAME diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 5db8ed3e2..df10ea3ce 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -145,7 +145,7 @@ verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr) - scm_tc7_objcode | type | flags - the struct scm_objcode C object - the parent of this objcode: either another objcode, a bytevector, - or, in the case of mmap types, file descriptors (as an inum) + or, in the case of mmap types, #f - "native code" -- not currently used. */ @@ -203,12 +203,11 @@ make_objcode_from_file (int fd) scm_from_size_t (total_len))); } - /* FIXME: we leak ourselves and the file descriptor. but then again so does - dlopen(). */ + (void) close (fd); return scm_permanent_object (scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0), (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)), - SCM_UNPACK (scm_from_int (fd)), 0)); + SCM_BOOL_F_BITS, 0)); } #else { diff --git a/libguile/print.c b/libguile/print.c index d8dd24c06..a1c36eb94 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -651,14 +651,20 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_with_fluids: scm_i_with_fluids_print (exp, port, pstate); break; - case scm_tc7_wvect: + case scm_tc7_array: ENTER_NESTED_DATA (pstate, exp, circref); - scm_puts_unlocked ("#w(", port); - goto common_vector_printer; - + scm_i_print_array (exp, port, pstate); + break; case scm_tc7_bytevector: scm_i_print_bytevector (exp, port, pstate); break; + case scm_tc7_bitvector: + scm_i_print_bitvector (exp, port, pstate); + break; + case scm_tc7_wvect: + ENTER_NESTED_DATA (pstate, exp, circref); + scm_puts_unlocked ("#w(", port); + goto common_vector_printer; case scm_tc7_vector: ENTER_NESTED_DATA (pstate, exp, circref); scm_puts_unlocked ("#(", port); diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index 5bba81c7f..92d4a9d70 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -546,17 +546,20 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, MY_VALIDATE_SUBSTRING_SPEC (3, s, 4, start, cstart, 5, end, cend); - len = cend - cstart; - SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart); - - target = scm_i_string_start_writing (target); - for (i = 0; i < cend - cstart; i++) + if (cstart < cend) { - scm_i_string_set_x (target, ctstart + i, - scm_i_string_ref (s, cstart + i)); + len = cend - cstart; + SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart); + + target = scm_i_string_start_writing (target); + for (i = 0; i < cend - cstart; i++) + { + scm_i_string_set_x (target, ctstart + i, + scm_i_string_ref (s, cstart + i)); + } + scm_i_string_stop_writing (); + scm_remember_upto_here_1 (target); } - scm_i_string_stop_writing (); - scm_remember_upto_here_1 (target); return SCM_UNSPECIFIED; } @@ -970,11 +973,13 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0, 4, end, cend); SCM_VALIDATE_CHAR (2, chr); - - str = scm_i_string_start_writing (str); - for (k = cstart; k < cend; k++) - scm_i_string_set_x (str, k, SCM_CHAR (chr)); - scm_i_string_stop_writing (); + if (cstart < cend) + { + str = scm_i_string_start_writing (str); + for (k = cstart; k < cend; k++) + scm_i_string_set_x (str, k, SCM_CHAR (chr)); + scm_i_string_stop_writing (); + } return SCM_UNSPECIFIED; } @@ -2089,11 +2094,14 @@ string_upcase_x (SCM v, size_t start, size_t end) { size_t k; - v = scm_i_string_start_writing (v); - for (k = start; k < end; ++k) - scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k))); - scm_i_string_stop_writing (); - scm_remember_upto_here_1 (v); + if (start < end) + { + v = scm_i_string_start_writing (v); + for (k = start; k < end; ++k) + scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k))); + scm_i_string_stop_writing (); + scm_remember_upto_here_1 (v); + } return v; } @@ -2152,11 +2160,14 @@ string_downcase_x (SCM v, size_t start, size_t end) { size_t k; - v = scm_i_string_start_writing (v); - for (k = start; k < end; ++k) - scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k))); - scm_i_string_stop_writing (); - scm_remember_upto_here_1 (v); + if (start < end) + { + v = scm_i_string_start_writing (v); + for (k = start; k < end; ++k) + scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k))); + scm_i_string_stop_writing (); + scm_remember_upto_here_1 (v); + } return v; } @@ -2219,27 +2230,30 @@ string_titlecase_x (SCM str, size_t start, size_t end) size_t i; int in_word = 0; - str = scm_i_string_start_writing (str); - for(i = start; i < end; i++) + if (start < end) { - ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i)); - if (scm_is_true (scm_char_alphabetic_p (ch))) - { - if (!in_word) - { - scm_i_string_set_x (str, i, uc_totitle (SCM_CHAR (ch))); - in_word = 1; - } - else - { - scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch))); - } - } - else - in_word = 0; + str = scm_i_string_start_writing (str); + for(i = start; i < end; i++) + { + ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i)); + if (scm_is_true (scm_char_alphabetic_p (ch))) + { + if (!in_word) + { + scm_i_string_set_x (str, i, uc_totitle (SCM_CHAR (ch))); + in_word = 1; + } + else + { + scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch))); + } + } + else + in_word = 0; + } + scm_i_string_stop_writing (); + scm_remember_upto_here_1 (str); } - scm_i_string_stop_writing (); - scm_remember_upto_here_1 (str); return str; } @@ -2309,22 +2323,25 @@ SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, static void string_reverse_x (SCM str, size_t cstart, size_t cend) { - SCM tmp; - - str = scm_i_string_start_writing (str); - if (cend > 0) + if (cstart < cend) { - cend--; - while (cstart < cend) - { - tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart)); - scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend)); - scm_i_string_set_x (str, cend, SCM_CHAR (tmp)); - cstart++; - cend--; - } + str = scm_i_string_start_writing (str); + if (cend > 0) + { + SCM tmp; + + cend--; + while (cstart < cend) + { + tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart)); + scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend)); + scm_i_string_set_x (str, cend, SCM_CHAR (tmp)); + cstart++; + cend--; + } + } + scm_i_string_stop_writing (); } - scm_i_string_stop_writing (); } @@ -2866,26 +2883,29 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, csto = csfrom + (cend - cstart); else csto = scm_to_int (sto); - if (cstart == cend && csfrom != csto) - SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); - SCM_ASSERT_RANGE (1, tstart, - ctstart + (csto - csfrom) <= scm_i_string_length (target)); - - p = 0; - target = scm_i_string_start_writing (target); - while (csfrom < csto) + if (csfrom < csto) { - size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart); - if (csfrom < 0) - scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t)); - else - scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t)); - csfrom++; - p++; - } - scm_i_string_stop_writing (); + if (cstart == cend) + SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); + SCM_ASSERT_RANGE (1, tstart, + ctstart + (csto - csfrom) <= scm_i_string_length (target)); + + p = 0; + target = scm_i_string_start_writing (target); + while (csfrom < csto) + { + size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart); + if (csfrom < 0) + scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t)); + else + scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t)); + csfrom++; + p++; + } + scm_i_string_stop_writing (); - scm_remember_upto_here_2 (target, s); + scm_remember_upto_here_2 (target, s); + } return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/srfi-60.c b/libguile/srfi-60.c index 264f4cbd5..1ed3c9e81 100644 --- a/libguile/srfi-60.c +++ b/libguile/srfi-60.c @@ -70,7 +70,7 @@ SCM_DEFINE (scm_srfi60_log2_binary_factors, "log2-binary-factors", 1, 0, 0, SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0, - (SCM index, SCM n, SCM bit), + (SCM index, SCM n, SCM newbit), "Return @var{n} with the bit at @var{index} set according to\n" "@var{newbit}. @var{newbit} should be @code{#t} to set the bit\n" "to 1, or @code{#f} to set it to 0. Bits other than at\n" @@ -86,7 +86,7 @@ SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0, int bb; ii = scm_to_ulong (index); - bb = scm_to_bool (bit); + bb = scm_to_bool (newbit); if (SCM_I_INUMP (n)) { diff --git a/libguile/strings.c b/libguile/strings.c index b9963010f..cb883fa73 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 2012 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 License @@ -436,6 +436,9 @@ scm_i_string_length (SCM str) int scm_i_is_narrow_string (SCM str) { + if (IS_SH_STRING (str)) + str = SH_STRING_STRING (str); + return !STRINGBUF_WIDE (STRING_STRINGBUF (str)); } @@ -446,6 +449,9 @@ scm_i_is_narrow_string (SCM str) int scm_i_try_narrow_string (SCM str) { + if (IS_SH_STRING (str)) + str = SH_STRING_STRING (str); + SET_STRING_STRINGBUF (str, narrow_stringbuf (STRING_STRINGBUF (str))); return scm_i_is_narrow_string (str); @@ -664,6 +670,12 @@ scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr) void scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr) { + if (IS_SH_STRING (str)) + { + p += STRING_START (str); + str = SH_STRING_STRING (str); + } + if (chr > 0xFF && scm_i_is_narrow_string (str)) SET_STRING_STRINGBUF (str, wide_stringbuf (STRING_STRINGBUF (str))); @@ -2243,7 +2255,7 @@ SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string) void scm_init_strings () { - scm_nullstr = scm_i_make_string (0, NULL, 1); + scm_nullstr = scm_i_make_string (0, NULL, 0); #include "libguile/strings.x" } diff --git a/libguile/strings.h b/libguile/strings.h index 0c163db5a..04a976211 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -85,7 +85,7 @@ - SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH is the same as scm_i_string_length. SCM_STRING_CHARS will throw - an error for for strings that are not null-terminated. There is + an error for strings that are not null-terminated. There is no wide version of this interface. */ diff --git a/libguile/tags.h b/libguile/tags.h index 54b74e0a2..fb550479d 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -3,7 +3,7 @@ #ifndef SCM_TAGS_H #define SCM_TAGS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -440,8 +440,8 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_program 79 #define scm_tc7_weak_set 85 #define scm_tc7_weak_table 87 -#define scm_tc7_unused_20 93 -#define scm_tc7_unused_11 95 +#define scm_tc7_array 93 +#define scm_tc7_bitvector 95 #define scm_tc7_unused_12 101 #define scm_tc7_unused_18 103 #define scm_tc7_unused_13 109 diff --git a/libguile/threads.c b/libguile/threads.c index 80631b454..0dba50f8a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1,4 +1,6 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, + * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 + * 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 License @@ -25,6 +27,7 @@ #include "libguile/bdw-gc.h" #include "libguile/_scm.h" +#include <stdlib.h> #if HAVE_UNISTD_H #include <unistd.h> #endif diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5395ed1f9..1de5edf5b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1,7 +1,8 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011 -;;;; Free Software Foundation, Inc. +;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 +;;;; 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 @@ -2979,7 +2980,7 @@ module '(ice-9 q) '(make-q q-length))}." ;; 0 by printing a newline, but we then advance it by printing ;; the prompt. However the port-column of the output port ;; does not typically correspond with the actual column on the - ;; screen, because the input is is echoed back! Since the + ;; screen, because the input is echoed back! Since the ;; input is line-buffered and thus ends with a newline, the ;; output will really start on column zero. So, here we zero ;; it out. See bug 9664. @@ -3463,7 +3464,7 @@ module '(ice-9 q) '(make-q q-length))}." ;;; {`load'.} ;;; ;;; Load is tricky when combined with relative paths, compilation, and -;;; the filesystem. If a path is relative, what is it relative to? The +;;; the file system. If a path is relative, what is it relative to? The ;;; path of the source file at the time it was compiled? The path of ;;; the compiled file? What if both or either were installed? And how ;;; do you get that information? Tricky, I say. diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 5f6115427..96422b5e4 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -1,6 +1,6 @@ ;;;; ftw.scm --- file system tree walk -;;;; Copyright (C) 2002, 2003, 2006, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012 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 @@ -389,7 +389,14 @@ ;;; `file-system-fold' & co. ;;; -(define* (file-system-fold enter? leaf down up skip init file-name +(define-syntax-rule (errno-if-exception expr) + (catch 'system-error + (lambda () + expr) + (lambda args + (system-error-errno args)))) + +(define* (file-system-fold enter? leaf down up skip error init file-name #:optional (stat lstat)) "Traverse the directory at FILE-NAME, recursively. Enter sub-directories only when (ENTER? PATH STAT RESULT) returns true. When @@ -397,7 +404,11 @@ a sub-directory is entered, call (DOWN PATH STAT RESULT), where PATH is the path of the sub-directory and STAT the result of (stat PATH); when it is left, call (UP PATH STAT RESULT). For each file in a directory, call (LEAF PATH STAT RESULT). When ENTER? returns false, call (SKIP -PATH STAT RESULT). Return the result of these successive applications. +PATH STAT RESULT). When an `opendir' or STAT call raises an exception, +call (ERROR PATH STAT ERRNO RESULT), with ERRNO being the operating +system error number that was raised. + +Return the result of these successive applications. When FILE-NAME names a flat file, (LEAF PATH STAT INIT) is returned. The optional STAT parameter defaults to `lstat'." @@ -409,7 +420,7 @@ The optional STAT parameter defaults to `lstat'." (let loop ((name file-name) (path "") - (dir-stat (false-if-exception (stat file-name))) + (dir-stat (errno-if-exception (stat file-name))) (result init) (visited vlist-null)) @@ -419,57 +430,60 @@ The optional STAT parameter defaults to `lstat'." (string-append path "/" name))) (cond - ((not dir-stat) + ((integer? dir-stat) ;; FILE-NAME is not readable. - (leaf full-name dir-stat result)) + (error full-name #f dir-stat result)) ((visited? visited dir-stat) (values result visited)) ((eq? 'directory (stat:type dir-stat)) ; true except perhaps the 1st time (if (enter? full-name dir-stat result) - (let ((dir (false-if-exception (opendir full-name))) + (let ((dir (errno-if-exception (opendir full-name))) (visited (mark visited dir-stat))) - (if dir - (let liip ((entry (readdir dir)) - (result (down full-name dir-stat result)) - (subdirs '())) - (cond ((eof-object? entry) - (begin - (closedir dir) - (let ((r+v - (fold (lambda (subdir result+visited) - (call-with-values - (lambda () - (loop (car subdir) - full-name - (cdr subdir) - (car result+visited) - (cdr result+visited))) - cons)) - (cons result visited) - subdirs))) - (values (up full-name dir-stat (car r+v)) - (cdr r+v))))) - ((or (string=? entry ".") - (string=? entry "..")) - (liip (readdir dir) - result - subdirs)) - (else - (let* ((child (string-append full-name "/" entry)) - (st (false-if-exception (stat child)))) - (if (and st (eq? (stat:type st) 'directory)) - (liip (readdir dir) - result - (alist-cons entry st subdirs)) - (liip (readdir dir) - (leaf child st result) - subdirs)))))) - - ;; Directory FULL-NAME not readable. - ;; XXX: It's up to the user to distinguish between not - ;; readable and not ENTER?. - (values (skip full-name dir-stat result) - visited))) + (cond + ((directory-stream? dir) + (let liip ((entry (readdir dir)) + (result (down full-name dir-stat result)) + (subdirs '())) + (cond ((eof-object? entry) + (begin + (closedir dir) + (let ((r+v + (fold (lambda (subdir result+visited) + (call-with-values + (lambda () + (loop (car subdir) + full-name + (cdr subdir) + (car result+visited) + (cdr result+visited))) + cons)) + (cons result visited) + subdirs))) + (values (up full-name dir-stat (car r+v)) + (cdr r+v))))) + ((or (string=? entry ".") + (string=? entry "..")) + (liip (readdir dir) + result + subdirs)) + (else + (let* ((child (string-append full-name "/" entry)) + (st (errno-if-exception (stat child)))) + (if (integer? st) ; CHILD is a dangling symlink? + (liip (readdir dir) + (error child #f st result) + subdirs) + (if (eq? (stat:type st) 'directory) + (liip (readdir dir) + result + (alist-cons entry st subdirs)) + (liip (readdir dir) + (leaf child st result) + subdirs)))))))) + (else + ;; Directory FULL-NAME not readable, but it is stat'able. + (values (error full-name dir-stat dir result) + visited)))) (values (skip full-name dir-stat result) (mark visited dir-stat)))) (else @@ -480,13 +494,14 @@ The optional STAT parameter defaults to `lstat'." #:optional (enter? (lambda (n s) #t)) (stat lstat)) "Return a tree of the form (FILE-NAME STAT CHILDREN ...) where STAT is -the result of (stat FILE-NAME) and CHILDREN are similar structures for +the result of (STAT FILE-NAME) and CHILDREN are similar structures for each file contained in FILE-NAME when it designates a directory. The optional ENTER? predicate is invoked as (ENTER? NAME STAT) and should return true to allow recursion into directory NAME; the default value is a procedure that always returns #t. When a directory does not match ENTER?, it nonetheless appears in the resulting tree, only with zero -children. The optional STAT parameter defaults to `lstat'." +children. The optional STAT parameter defaults to `lstat'. Return #f +when FILE-NAME is not readable." (define (enter?* name stat result) (enter? name stat)) (define (leaf name stat result) @@ -504,8 +519,15 @@ children. The optional STAT parameter defaults to `lstat'." rest)))) (define skip ; keep an entry for skipped directories leaf) + (define (error name stat errno result) + (if (string=? name file-name) + result + (leaf name stat result))) - (caar (file-system-fold enter?* leaf down up skip '(()) file-name stat))) + (match (file-system-fold enter?* leaf down up skip error '(()) + file-name stat) + (((tree)) tree) + ((()) #f))) ; FILE-NAME is unreadable (define* (scandir name #:optional (select? (const #t)) (entry<? string-locale<?)) @@ -532,7 +554,12 @@ of file names is sorted according to ENTRY<?, which defaults to ;; All the sub-directories are skipped. (cons (basename name) result)) - (and=> (file-system-fold enter? leaf down up skip #f name stat) + (define (error name* stat errno result) + (if (string=? name name*) ; top-level NAME is unreadable + result + (cons (basename name*) result))) + + (and=> (file-system-fold enter? leaf down up skip error #f name stat) (lambda (files) (sort files entry<?)))) diff --git a/module/ice-9/test.scm b/module/ice-9/test.scm index f6080e4cf..179cfc35e 100644 --- a/module/ice-9/test.scm +++ b/module/ice-9/test.scm @@ -17,7 +17,7 @@ ;;;; "test.scm" Test correctness of scheme implementations. ;;; Author: Aubrey Jaffer ;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately -;;; won't pass. Made the the tests (test-cont), (test-sc4), and +;;; won't pass. Made the tests (test-cont), (test-sc4), and ;;; (test-delay) start to run automatically. ;;; This includes examples from diff --git a/module/language/elisp/runtime/macros.scm b/module/language/elisp/runtime/macros.scm index a62f721e7..b28706781 100644 --- a/module/language/elisp/runtime/macros.scm +++ b/module/language/elisp/runtime/macros.scm @@ -81,7 +81,7 @@ (progn ,@(cdr cur)) ,rest)))))))) -;;; The and and or forms can also be easily defined with macros. +;;; The `and' and `or' forms can also be easily defined with macros. (built-in-macro and (case-lambda diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 2a18342d3..f83d77e76 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -238,7 +238,7 @@ c) (list body))) (else - ;; Otherwise for plain letrec, evaluate the the "complex" + ;; Otherwise for plain letrec, evaluate the "complex" ;; bindings, in a `let' to indicate that order doesn't ;; matter, and bind to their variables. (list diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index d2347b0d1..d2531b59d 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -652,7 +652,7 @@ has just one element then that's the return value." (define map! map) (define (filter-map proc list1 . rest) - "Apply PROC to to the elements of LIST1... and return a list of the + "Apply PROC to the elements of LIST1... and return a list of the results as per SRFI-1 `map', except that any #f results are omitted from the list returned." (check-arg procedure? proc filter-map) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 953c93602..0bc11a30f 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -93,7 +93,7 @@ ;;; This function is among the trickiest I've ever written. I tried many ;;; variants. In the end, simple is best, of course. ;;; -;;; After turning this around a number of times, it seems that the the +;;; After turning this around a number of times, it seems that the ;;; desired behavior is that .go files should exist in a path, for ;;; searching. That is orthogonal to this function. For writing .go ;;; files, either you know where they should go, in which case you tell diff --git a/module/system/base/target.scm b/module/system/base/target.scm index a81b3d9f5..304056de2 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -1,6 +1,6 @@ ;;; Compilation targets -;; Copyright (C) 2011 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012 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 @@ -82,9 +82,9 @@ (cond ((string-match "^i[0-9]86$" cpu) 4) ((string-match "64$" cpu) 8) ((string-match "64[lbe][lbe]$" cpu) 8) - ((member cpu '("sparc" "powerpc" "mips")) 4) + ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4) ((string-match "^arm.*" cpu) 4) - (else "unknown CPU word size" cpu)))) + (else (error "unknown CPU word size" cpu))))) (define (triplet-cpu t) (substring t 0 (string-index t #\-))) diff --git a/module/web/http.scm b/module/web/http.scm index afe70a7fd..b060af91e 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -805,9 +805,6 @@ ordered alist." (display-digits (date-second date) 2 port) (display " GMT" port))) -(define (write-uri uri port) - (display (uri->string uri) port)) - (define (parse-entity-tag val) (if (string-prefix? "W/" val) (cons (parse-qstring val 2) #f) @@ -1082,7 +1079,18 @@ three values: the method, the URI, and the version." "Write the first line of an HTTP request to @var{port}." (display method port) (display #\space port) - (write-uri uri port) + (let ((path (uri-path uri)) + (query (uri-query uri))) + (if (not (string-null? path)) + (display path port)) + (if query + (begin + (display "?" port) + (display query port))) + (if (and (string-null? path) + (not query)) + ;; Make sure we display something. + (display "/" port))) (display #\space port) (write-http-version version port) (display "\r\n" port)) @@ -1506,7 +1514,15 @@ phrase\"." ;; Expires = HTTP-date ;; -(declare-date-header! "Expires") +(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT")) + +(declare-header! "Expires" + (lambda (str) + (if (member str '("0" "-1")) + *date-in-the-past* + (parse-date str))) + date? + write-date) ;; Last-Modified = HTTP-date ;; diff --git a/test-suite/lib.scm b/test-suite/lib.scm index ecf39245a..9a03dc915 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -119,7 +119,7 @@ ;;;; ;;;; * (pass-if-exception name exception body) will pass if the execution of ;;;; body causes the given exception to be thrown. If no exception is -;;;; thrown, the test fails. If some other exception is thrown, is is an +;;;; thrown, the test fails. If some other exception is thrown, it is an ;;;; error. ;;;; * (expect-fail-exception name exception body) will pass unexpectedly if ;;;; the execution of body causes the given exception to be thrown. If no diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c index d210a1982..c8dc3a7e4 100644 --- a/test-suite/standalone/test-num2integral.c +++ b/test-suite/standalone/test-num2integral.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010, 2011 + * 2012 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 License @@ -34,8 +35,7 @@ SCM call_num2ulong_long_body (void *data); SCM out_of_range_handler (void *data, SCM key, SCM args) { - assert (scm_is_true - (scm_equal_p (key, scm_from_locale_symbol ("out-of-range")))); + assert (scm_is_eq (key, scm_from_locale_symbol ("out-of-range"))); return SCM_BOOL_T; } diff --git a/test-suite/standalone/test-pthread-create-secondary.c b/test-suite/standalone/test-pthread-create-secondary.c index fe39c2a26..e145fa5bc 100644 --- a/test-suite/standalone/test-pthread-create-secondary.c +++ b/test-suite/standalone/test-pthread-create-secondary.c @@ -27,7 +27,7 @@ #include <stdlib.h> #include <libguile.h> -#include <gc/gc_version.h> +#include <gc/gc.h> /* Up to GC 7.2alpha5, calling `GC_INIT' from a secondary thread would diff --git a/test-suite/standalone/test-scm-spawn-thread.c b/test-suite/standalone/test-scm-spawn-thread.c index aa790cdbb..f6d561aa1 100644 --- a/test-suite/standalone/test-scm-spawn-thread.c +++ b/test-suite/standalone/test-scm-spawn-thread.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2011 Free Software Foundation, Inc. +/* Copyright (C) 2011, 2012 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 License diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index fa179d400..be983a16a 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -1,6 +1,6 @@ ;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*- ;;;; -;;;; Copyright 2006, 2011 Free Software Foundation, Inc. +;;;; Copyright 2006, 2011, 2012 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,71 @@ ;;; `file-system-fold' & co. ;;; +(define %top-builddir + (canonicalize-path (getcwd))) + (define %top-srcdir (assq-ref %guile-build-info 'top_srcdir)) (define %test-dir (string-append %top-srcdir "/test-suite")) +(define (make-file-tree dir tree) + "Make file system TREE at DIR." + (define (touch file) + (call-with-output-file file + (cut display "" <>))) + + (let loop ((dir dir) + (tree tree)) + (define (scope file) + (string-append dir "/" file)) + + (match tree + (('directory name (body ...)) + (mkdir (scope name)) + (for-each (cute loop (scope name) <>) body)) + (('directory name (? integer? mode) (body ...)) + (mkdir (scope name)) + (for-each (cute loop (scope name) <>) body) + (chmod (scope name) mode)) + ((file) + (touch (scope file))) + ((file (? integer? mode)) + (touch (scope file)) + (chmod (scope file) mode)) + ((from '-> to) + (symlink to (scope from)))))) + +(define (delete-file-tree dir tree) + "Delete file TREE from DIR." + (let loop ((dir dir) + (tree tree)) + (define (scope file) + (string-append dir "/" file)) + + (match tree + (('directory name (body ...)) + (for-each (cute loop (scope name) <>) body) + (rmdir (scope name))) + (('directory name (? integer? mode) (body ...)) + (chmod (scope name) #o755) ; make sure it can be entered + (for-each (cute loop (scope name) <>) body) + (rmdir (scope name))) + ((from '-> _) + (delete-file (scope from))) + ((file _ ...) + (delete-file (scope file)))))) + +(define-syntax-rule (with-file-tree dir tree body ...) + (dynamic-wind + (lambda () + (make-file-tree dir tree)) + (lambda () + body ...) + (lambda () + (delete-file-tree dir tree)))) + (with-test-prefix "file-system-fold" (pass-if "test-suite" @@ -98,10 +157,11 @@ (leaf (lambda (n s r) (cons `(leaf ,n) r))) (down (lambda (n s r) (cons `(down ,n) r))) (up (lambda (n s r) (cons `(up ,n) r))) - (skip (lambda (n s r) (cons `(skip ,n) r)))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n) r)))) (define seq (reverse - (file-system-fold enter? leaf down up skip '() %test-dir))) + (file-system-fold enter? leaf down up skip error '() %test-dir))) (match seq ((('down (? (cut string=? <> %test-dir))) @@ -123,8 +183,9 @@ (leaf (lambda (n s r) (cons `(leaf ,n) r))) (down (lambda (n s r) (cons `(down ,n) r))) (up (lambda (n s r) (cons `(up ,n) r))) - (skip (lambda (n s r) (cons `(skip ,n) r)))) - (equal? (file-system-fold enter? leaf down up skip '() %test-dir) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n) r)))) + (equal? (file-system-fold enter? leaf down up skip error '() %test-dir) `((skip , %test-dir))))) (pass-if "test-suite/lib.scm (flat file)" @@ -133,9 +194,67 @@ (down (lambda (n s r) (cons `(down ,n) r))) (up (lambda (n s r) (cons `(up ,n) r))) (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n) r))) (name (string-append %test-dir "/lib.scm"))) - (equal? (file-system-fold enter? leaf down up skip '() name) - `((leaf ,name)))))) + (equal? (file-system-fold enter? leaf down up skip error '() name) + `((leaf ,name))))) + + (pass-if "ENOENT" + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r))) + (name "/.does-not-exist.")) + (equal? (file-system-fold enter? leaf down up skip error '() name) + `((error ,name ,ENOENT))))) + + (pass-if "EACCES" + (with-file-tree %top-builddir '(directory "test-EACCES" #o000 + (("a") ("b"))) + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r))) + (name (string-append %top-builddir "/test-EACCES"))) + (equal? (file-system-fold enter? leaf down up skip error '() name) + `((error ,name ,EACCES)))))) + + (pass-if "dangling symlink and lstat" + (with-file-tree %top-builddir '(directory "test-dangling" + (("dangling" -> "xxx"))) + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r))) + (name (string-append %top-builddir "/test-dangling"))) + (equal? (file-system-fold enter? leaf down up skip error '() + name) + `((up ,name) + (leaf ,(string-append name "/dangling")) + (down ,name)))))) + + (pass-if "dangling symlink and stat" + ;; Same as above, but using `stat' instead of `lstat'. + (with-file-tree %top-builddir '(directory "test-dangling" + (("dangling" -> "xxx"))) + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r))) + (name (string-append %top-builddir "/test-dangling"))) + (equal? (file-system-fold enter? leaf down up skip error '() + name stat) + `((up ,name) + (error ,(string-append name "/dangling") ,ENOENT) + (down ,name))))))) (with-test-prefix "file-system-tree" @@ -165,7 +284,10 @@ (lset-intersection string=? files expected) expected))) (_ #f)) - children))))) + children)))) + + (pass-if "ENOENT" + (not (file-system-tree "/.does-not-exist.")))) (with-test-prefix "scandir" @@ -188,4 +310,11 @@ #t)))) (pass-if "flat file" - (not (scandir (string-append %test-dir "/Makefile.am"))))) + (not (scandir (string-append %test-dir "/Makefile.am")))) + + (pass-if "EACCES" + (not (scandir "/.does-not-exist.")))) + +;;; Local Variables: +;;; eval: (put 'with-file-tree 'scheme-indent-function 2) +;;; End: diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index a5e418f67..05670516d 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,6 +1,6 @@ ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*- ;;;; -;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -138,7 +138,11 @@ (under-locale-or-unresolved %french-utf8-locale thunk)) (define (under-turkish-utf8-locale-or-unresolved thunk) - (under-locale-or-unresolved %turkish-utf8-locale thunk)) + ;; FreeBSD 8.2 has a broken tr_TR locale where `i' is mapped to + ;; uppercase `I' instead of `İ', so disable tests on that platform. + (if (string-contains %host-type "freebsd8") + (throw 'unresolved) + (under-locale-or-unresolved %turkish-utf8-locale thunk))) (define (under-german-utf8-locale-or-unresolved thunk) (under-locale-or-unresolved %german-utf8-locale thunk)) diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 50e5fa73f..1cf8d65e8 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -1,7 +1,7 @@ ;;;; load.test --- test LOAD and path searching functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; -;;;; Copyright (C) 1999, 2001, 2006, 2010 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2006, 2010, 2012 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 @@ -18,8 +18,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-load) - :use-module (test-suite lib) - :use-module (test-suite guile-test)) + #:use-module (test-suite lib) + #:use-module (test-suite guile-test) + #:use-module (system base compile)) (define temp-dir (data-file-name "load-test.dir")) @@ -124,4 +125,17 @@ (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm") (try-search-with-extensions path "ugly.ss" extensions #f)) +(with-test-prefix "return value of `load'" + (let ((temp-file (in-vicinity temp-dir "foo.scm"))) + (call-with-output-file temp-file + (lambda (port) + (write '(+ 2 3) port) + (newline port))) + (pass-if "primitive-load" + (equal? 5 (primitive-load temp-file))) + (let ((temp-compiled-file (in-vicinity temp-dir "foo.go"))) + (compile-file temp-file #:output-file temp-compiled-file) + (pass-if "load-compiled" + (equal? 5 (load-compiled temp-compiled-file)))))) + (delete-tree temp-dir) diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test index 25dd4c293..ceb6e562b 100644 --- a/test-suite/tests/procprop.test +++ b/test-suite/tests/procprop.test @@ -1,7 +1,7 @@ ;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*- ;;;; Ludovic Courtès <ludo@gnu.org> ;;;; -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012 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 @@ -72,4 +72,10 @@ (pass-if "opt, eval" (equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t) (current-module))) - '(2 1 #f)))) + '(2 1 #f))) + + (if (include-deprecated-features) + (pass-if-exception "set-procedure-properties! arity" + '(misc-error . "arity is a read-only property") + (set-procedure-properties! (lambda x x) '((arity . 3)))) + #t)) diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index e26fdada3..1e4243cae 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -35,7 +35,7 @@ ;;;; Author: Aubrey Jaffer ;;;; Modified: Mikael Djurfeldt ;;;; Removed tests which Guile deliberately -;;;; won't pass. Made the the tests (test-cont), (test-sc4), and +;;;; won't pass. Made the tests (test-cont), (test-sc4), and ;;;; (test-delay) start to run automatically. ;;;; Modified: Jim Blandy ;;;; adapted to new Guile test suite framework diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index 832542edc..c2b65a64c 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -147,6 +147,14 @@ (define char-code-limit 256) +;; Since `regexp-quote' uses string ports, and since it is used below +;; with non-ASCII characters, these ports must be Unicode-capable. +(define-syntax with-unicode + (syntax-rules () + ((_ exp) + (with-fluids ((%default-port-encoding "UTF-8")) + exp)))) + (with-test-prefix "regexp-quote" (pass-if-exception "no args" exception:wrong-num-args @@ -175,7 +183,7 @@ (s (string c))) (pass-if (list "char" i (format #f "~s ~s" c s)) (with-ascii-or-latin1-locale i - (let* ((q (regexp-quote s)) + (let* ((q (with-unicode (regexp-quote s))) (m (regexp-exec (make-regexp q flag) s))) (and (= 0 (match:start m)) (= 1 (match:end m)))))))) @@ -187,7 +195,7 @@ ((>= i char-code-limit)) (let* ((c (integer->char i)) (s (string #\a c)) - (q (regexp-quote s))) + (q (with-unicode (regexp-quote s)))) (pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q)) (with-ascii-or-latin1-locale i (let* ((m (regexp-exec (make-regexp q flag) s))) @@ -196,7 +204,8 @@ (pass-if "string of all chars" (with-latin1-locale - (let ((m (regexp-exec (make-regexp (regexp-quote allchars) + (let ((m (regexp-exec (make-regexp (with-unicode + (regexp-quote allchars)) flag) allchars))) (and (= 0 (match:start m)) (= (string-length allchars) (match:end m))))))))) diff --git a/test-suite/tests/srfi-67.test b/test-suite/tests/srfi-67.test index e5a4471ee..312282e92 100644 --- a/test-suite/tests/srfi-67.test +++ b/test-suite/tests/srfi-67.test @@ -36,7 +36,7 @@ ; Test engine ; =========== ; -; We use an extended version of the the checker of SRFI-42 (with +; We use an extended version of the checker of SRFI-42 (with ; Felix' reduction on codesize) for running a batch of tests for ; the various procedures of 'compare.scm'. Moreover, we use the ; comprehensions of SRFI-42 to generate examples systematically. diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test index 7ce39badb..b2ee41e1b 100644 --- a/test-suite/tests/statprof.test +++ b/test-suite/tests/statprof.test @@ -75,7 +75,7 @@ (let ((drift-fraction (/ max-diff average))) (or (< drift-fraction max-allowed-drift) - ;; don't stop the the test suite for what statistically is + ;; don't stop the test suite for what statistically is ;; bound to happen. (throw 'unresolved (pk average drift-fraction)))))))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index ccc8d9804..5163bac00 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -81,6 +81,8 @@ (define exception:too-many-args "too many arguments") +(define exception:zero-expression-sequence + "sequence of zero expressions") ;; (put 'pass-if-syntax-error 'scheme-indent-function 1) @@ -148,12 +150,12 @@ (with-test-prefix "begin" - (pass-if "legal (begin)" + (pass-if "valid (begin)" (eval '(begin (begin) #t) (interaction-environment))) (if (not (include-deprecated-features)) - (pass-if-syntax-error "illegal (begin)" - exception:generic-syncase-error + (pass-if-syntax-error "invalid (begin)" + exception:zero-expression-sequence (eval '(begin (if #t (begin)) #t) (interaction-environment))))) (define-syntax matches? |