[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-299-g5796
|
From: |
No Itisnt |
|
Subject: |
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-299-g57965d0 |
|
Date: |
Sun, 15 Aug 2010 07:08:15 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=57965d0bcfeeb9272cf9bd1e9fe4b633ebebdf77
The branch, lua has been updated
via 57965d0bcfeeb9272cf9bd1e9fe4b633ebebdf77 (commit)
via 499e516365afd55b6d49c95640f507c32e260f0a (commit)
via 52aef890ba4408c232364c9dd0ed71c27bdad0a3 (commit)
via 5326d59668a0f49cbbf5a8f0b8507974ccc8d554 (commit)
via 1e1aaf14ab68f002b9766099fe4ab806546c1e02 (commit)
via f1196bf38bb52df666e026916c3f0ac6197b036b (commit)
via 802b47bdc6232f3726860ce8ae17e4b422061620 (commit)
via b24b7deb000ee4108c5e3a0a2cb3d7494973a7a4 (commit)
via 58daadd9825bf1db3e8958a8b41f6316ec3db7fd (commit)
via 1435c7dcf8a520daba1d221d4da7ff81119e649c (commit)
via 8a4ed2dd34c86eb451c5555a85f64f3fbdf9cef6 (commit)
via 220058a8353815f2cefa67e2510b7132991cf7a7 (commit)
via 3470a299117479402542fda73b5d64dbd905de6d (commit)
via 08fc523b0eb477e137d1f6c64c38851f6cddb514 (commit)
via 4f9691174ddf83c6b5502b6b71262484c7f936e0 (commit)
via 3d4f8e3c2dd917bee6c5a55be3349234211faab1 (commit)
via 5bc97ad5dd7baa1d9f19571fed0fe6a339ed0688 (commit)
via 66ad445dcfaa712a0f0b3f7d23c49b90165e1eaf (commit)
via e5f7f675d052a0ae34676cb040cc283688477b90 (commit)
via ba270f8c267f8886636939078a4c6f6b1f8107cd (commit)
via 869bfe86af41ad92261128a1784bfb6638f78484 (commit)
via bc325e763f540048adc0e6375172af5cfc38742e (commit)
via ca290a89f3109f125f1eb6eeea066053d4b52e95 (commit)
via 69724dde0aaa00e356502554c6bb587c1088563b (commit)
via 935c7acac73667d0e3a9239f8a156f163baed6ce (commit)
via 18e90860d12c7b54192046eb877153964808cc21 (commit)
via 551b96d294f3b09c37124562e3da64a7bd399666 (commit)
via f9560a348e83ec3c494aee0d42b056383392ffca (commit)
via 2af6e1351da68c09d6b50be535901a4f85a4807a (commit)
via 7387c231ee382a36a13a04c9f3b247b1667f0397 (commit)
via 183a2a224b555a29ab311ffcb6abd529a0bdffc1 (commit)
via 22697acbc9bae9db44f5f2abcf8d39617d338ad2 (commit)
via 854aa906b45b09c0f5bb8b179851e68f878b3aa0 (commit)
via 5b46a8c2c8f41581dd5576c8dcc06e8bde8cd849 (commit)
via 9defb64118774c8f1a1f6af05d6f1705e7a40619 (commit)
via 17fc9efecbc9cb0c7e32664dbd0e2c863194cd7f (commit)
via d4149a510e4a87915b625255f4de3301510d810c (commit)
via 1af772303bf4eafb632a95bf4015a7736275e9e7 (commit)
via fefd60ba4ba751712c45c95362bbc2f858890678 (commit)
via a2a95453eb62dc489e6376f8e987db668837ba14 (commit)
via 1d454874c14423072e0b0e9ab7aaaaac81d376e0 (commit)
via 99a0ee662050ad31e74acb3390d6901e3c916f57 (commit)
via b606ff6af9c9ec7fc3c4473c09ce1e95c18f024a (commit)
via 4ca48269976e17b2530728cce7df63843a6ce2b0 (commit)
via 77b139121d0344d8a89f4d8b85739a3447bac196 (commit)
via 2d6a14adc901ea71409ef82c4021f235e99d420d (commit)
via dbd891c7122e037bb577f056ee5acfa1fe4392d2 (commit)
from 21a2bac977305f14557214454676ab06c97c8968 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 57965d0bcfeeb9272cf9bd1e9fe4b633ebebdf77
Author: No Itisnt <address@hidden>
Date: Sun Aug 15 02:07:37 2010 -0500
lua: Remove mistakenly added scratch file. Add not operator. Fix some
runtime functions.
commit 499e516365afd55b6d49c95640f507c32e260f0a
Author: No Itisnt <address@hidden>
Date: Sun Aug 15 01:10:19 2010 -0500
lua: Partial implementation of list for loops; attempts to call nonexistent
global functions now cause a helpful error
commit 52aef890ba4408c232364c9dd0ed71c27bdad0a3
Author: No Itisnt <address@hidden>
Date: Fri Aug 13 14:35:17 2010 -0500
lua: Working on numeric for loops
commit 5326d59668a0f49cbbf5a8f0b8507974ccc8d554
Author: No Itisnt <address@hidden>
Date: Wed Aug 11 21:55:30 2010 -0500
lua: Imeplement 'break' which I completely forgot to do
commit 1e1aaf14ab68f002b9766099fe4ab806546c1e02
Merge: f1196bf 802b47b
Author: No Itisnt <address@hidden>
Date: Mon Aug 9 19:37:52 2010 -0500
Merge branch 'master' into lua
commit f1196bf38bb52df666e026916c3f0ac6197b036b
Author: No Itisnt <address@hidden>
Date: Mon Aug 9 19:37:17 2010 -0500
lua: Insignificant changes
-----------------------------------------------------------------------
Summary of changes:
AUTHORS | 2 +-
NEWS | 579 ++++++++++++++------
README | 17 +-
am/guilec | 25 +-
configure.ac | 10 -
doc/ref/Makefile.am | 2 +-
doc/ref/api-binding.texi | 151 +++---
doc/ref/api-data.texi | 22 +-
doc/ref/api-deprecated.texi | 31 +
doc/ref/api-discdepr.texi | 38 --
doc/ref/api-foreign.texi | 250 ++++-----
doc/ref/api-macros.texi | 66 +++-
doc/ref/compiler.texi | 6 +-
doc/ref/guile.texi | 5 +-
doc/ref/r6rs.texi | 55 ++
doc/ref/repl-modules.texi | 34 +--
doc/ref/scheme-using.texi | 4 +-
libguile.h | 1 -
libguile/Makefile.am | 14 +-
libguile/__scm.h | 2 -
libguile/boolean.h | 14 +-
libguile/deprecated.c | 381 +++++++++++++-
libguile/deprecated.h | 97 ++++
libguile/discouraged.c | 307 -----------
libguile/discouraged.h | 184 -------
libguile/dynl.c | 38 +-
libguile/dynl.h | 2 +-
libguile/eq.h | 9 +-
libguile/evalext.c | 2 +-
libguile/foreign.c | 386 +++++---------
libguile/foreign.h | 91 +--
libguile/gc.c | 2 +-
libguile/gen-scmconfig.c | 36 +-
libguile/goops.c | 2 +-
libguile/gsubr.c | 7 +-
libguile/gsubr.h | 13 +-
libguile/init.c | 5 -
libguile/load.c | 24 +-
libguile/load.h | 3 +-
libguile/numbers.c | 14 +-
libguile/numbers.h | 6 +-
libguile/pairs.h | 10 +-
libguile/print.c | 4 +-
libguile/random.c | 273 ++++++----
libguile/random.h | 32 +-
libguile/snarf.h | 8 +-
libguile/srfi-4.c | 4 -
libguile/srfi-4.h | 6 +-
libguile/symbols.h | 14 +-
libguile/tags.h | 2 +-
libguile/vectors.c | 10 +-
libguile/vm-engine.c | 2 +
libguile/vm-i-system.c | 16 +-
meta/guile-2.0.pc.in | 2 +-
module/ice-9/boot-9.scm | 2 +-
module/language/lua/compile-tree-il.scm | 227 ++++++--
module/language/lua/lexer.scm | 5 +-
module/language/lua/parser.scm | 94 +++-
module/language/lua/runtime.scm | 77 ++-
module/language/lua/spec.scm | 4 +-
module/rnrs.scm | 2 +-
module/rnrs/base.scm | 9 +-
module/rnrs/lists.scm | 4 +-
module/system/base/compile.scm | 5 -
module/system/foreign.scm | 38 ++-
module/system/repl/debug.scm | 6 +-
module/system/repl/repl.scm | 16 +-
test-suite/Makefile.am | 2 +
test-suite/standalone/test-conversion.c | 8 +-
test-suite/standalone/test-ffi | 13 +-
test-suite/standalone/test-num2integral.c | 45 +--
test-suite/tests/foreign.test | 78 ++-
test-suite/tests/lua-eval-2.test | 10 +-
test-suite/tests/lua-eval.test | 1 +
test-suite/tests/lua-scratch.test | 23 -
.../tests/{r6rs-eval.test => r6rs-base.test} | 21 +-
.../tests/{r6rs-eval.test => r6rs-lists.test} | 20 +-
test-suite/tests/vectors.test | 81 +++-
78 files changed, 2304 insertions(+), 1807 deletions(-)
create mode 100644 doc/ref/api-deprecated.texi
delete mode 100644 doc/ref/api-discdepr.texi
delete mode 100644 libguile/discouraged.c
delete mode 100644 libguile/discouraged.h
delete mode 100644 test-suite/tests/lua-scratch.test
copy test-suite/tests/{r6rs-eval.test => r6rs-base.test} (64%)
copy test-suite/tests/{r6rs-eval.test => r6rs-lists.test} (68%)
diff --git a/AUTHORS b/AUTHORS
index 749ffd6..d756a74 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -122,7 +122,7 @@ Implemented support for double-word heap cells and
converted some
smobs to use them.
In the subdirectory libguile, wrote:
guardians.c guardians.h filter-doc-snarfage.c
- guile-snarf-docs.in guile-snarf-docs-texi.in
+ guile-snarf-docs.in
In the subdirectory libguile, changed extensively:
gc.c gc.h
In the subdirectory ice-9, wrote:
diff --git a/NEWS b/NEWS
index 1939a2b..c6caed3 100644
--- a/NEWS
+++ b/NEWS
@@ -4,253 +4,341 @@ See the end for copying conditions.
Please send Guile bug reports to address@hidden
-
-(During the 1.9 series, we will keep an incremental NEWS for the latest
-prerelease, and a full NEWS corresponding to 1.8 -> 2.0.)
-Changes in 1.9.11 (since the 1.9.10 prerelease):
+Note: During the 1.9 series, we will keep an incremental NEWS for the
+latest prerelease, and a full NEWS corresponding to 1.8 -> 2.0.
-** Renamed module: (rnrs bytevectors)
-
-This module was called (rnrs bytevector), its name from earlier drafts
-of the R6RS. Its name has been changed. Users of previous 1.9 preleases
-may want to search for any stale rnrs/bytevector .go or .scm file, and
-delete them.
+Changes in 1.9.12 (since the 1.9.11 prerelease):
+
+** Many R6RS bugfixes
-** New module: (sxml match)
+`(rnrs bytevectors)' and `(rnrs io ports)' now have version information,
+like the rest of the modules. The `(rnrs unicode)' module is now
+re-exported by `(rnrs)'. Top-level `import' forms may have more than one
+clause. Warnings about duplicate bindings have been fixed, along with
+some typos in the modules. There were a number of other bugfixes as well.
-Guile has incorporated Jim Bender's `sxml-match' library. See
-"sxml-match' in the manual for more information. Thanks, Jim!
+For the current list of known R6RS incompatibilities, see "R6RS
+Incompatibilities" in the manual.
-** New module: (srfi srfi-9 gnu)
+** Documentation for standard R6RS libraries
-This module adds an extension to srfi-9, `set-record-type-printer!'. See
-"SRFI-9" in the manual for more information.
+See "R6RS Standard Libraries" in the manual, for more details.
-** Support for R6RS libraries
+** Support for `letrec*'
-The `library' and `import' forms from the latest Scheme report have been
-added to Guile, in such a way that R6RS libraries share a namespace with
-Guile modules. R6RS modules may import Guile modules, and are available
-for Guile modules to import via use-modules and all the rest. See "R6RS
-Libraries" in the manual for more information.
+Guile now supports letrec*, a form of letrec in which the identifiers
+are bound in order. See "Local Bindings" in the manual, for more
+details.
-** Implementations of R6RS libraries
+** Internal definitions now expand to `letrec*'
-Guile now has implementations for all of the libraries defined in the
-R6RS. Thanks to Julian Graham for this excellent hack. See "R6RS
-Standard Libraries" in the manual for a full list of libraries.
+Following the R6RS, internal definitions now expand to letrec* instead
+of letrec. The following program is invalid for R5RS, but valid for
+R6RS:
-** Partial R6RS compatibility
+ (define (foo)
+ (define bar 10)
+ (define baz (+ bar 20))
+ baz)
-Guile now has enough support for R6RS to run a reasonably large subset
-of R6RS programs.
+ ;; R5RS and Guile <= 1.8:
+ (foo) => Unbound variable: bar
+ ;; R6RS and Guile >= 2.0:
+ (foo) => 30
-Guile is not fully R6RS compatible. Many incompatibilities are simply
-bugs, though some parts of Guile will remain R6RS-incompatible for the
-foreseeable future. See "R6RS Incompatibilities" in the manual, for more
+This change should not affect correct R5RS programs, or programs written
+in earlier Guile dialects.
+
+** Recursive debugging REPL on error
+
+When Guile sees an error, instead of dropping into a special debugging
+prompt, it will enter a recursive REPL in the dynamic context of the
+error. See "Error Handling" in the manual, for more information.
+
+A recursive REPL is the same as any other REPL, except that it
+has been augmented with debugging information, so that one can inspect
+the context of the error. The debugger has been integrated with the REPL
+via a set of debugging meta-commands.
+
+For example, one may access a backtrace with `,backtrace' (or
+`,bt'). See "Interactive Debugging" in the manual, for more
information.
-Please contact address@hidden if you have found an issue not
-mentioned in that compatibility list.
-
-** Macro expansion produces structures instead of s-expressions
+** Readline tab completion for arguments
-In the olden days, macroexpanding an s-expression would yield another
-s-expression. Though the lexical variables were renamed, expansions of
-core forms like `if' and `begin' were still non-hygienic, as they relied
-on the toplevel definitions of `if' et al being the conventional ones.
+When readline is enabled, tab completion works for arguments too, not
+just for the operator position.
-The solution is to expand to structures instead of s-expressions. There
-is an `if' structure, a `begin' structure, a `toplevel-ref' structure,
-etc. The expander already did this for compilation, producing Tree-IL
-directly; it has been changed now to do so when expanding for the
-evaluator as well.
+** Various REPL robustness fixes
-The real truth is somewhat more involved: Tree-IL doesn't exist until
-modules have been booted, but we need the expander to boot modules, and
-additionally we need a boot expander before psyntax is loaded. So a
-subset of Tree-IL is defined in C, and the boot expander produces these
-"macroexpanded" structures. Psyntax has been modified to produce those
-structures as well. When Tree-IL loads, it incorporates those structures
-directly as part of its language.
+The REPL no longer enters the debugger when an error occurs at read-time
+and compile-time, or when executing meta-commands. Additionally, the
+REPL is more strict about the ports that it uses, saving the current
+input and output ports at startup and using those ports when entering
+recursive prompts. This allows debugging of an error within
+e.g. `call-with-input-port'.
-Finally, the evaluator has been adapted to accept these "expanded"
-structures, and enhanced to better support the gamut of this subset of
-Tree-IL, including `lambda*' and `case-lambda'. This was a much-needed
-harmonization between the compiler, expander, and evaluator.
+Finally, Ctrl-d can now be used to exit a recursive REPL, dropping the
+user back to the parent REPL.
-** Deprecated `scm_badargsp'
+** Better procedure name and source location propagation
-This function is unused in Guile, but was part of its API.
+There was a bug in 1.9.11 which would leave most procedures un-named;
+this and other previous deficiencies have been fixed.
-** `sxml->xml' enhancement
-
-`sxml->xml' from `(sxml simple)' can now handle the result of
-`xml->sxml'. See bug #29260 for more information.
+** New macro: `current-source-location'
-** New module: (system vm coverage)
+See FIXME in the manual, for more information.
-This new module can produce code coverage reports for compiled Scheme
-code on a line-by-line level. See "Code Coverage" in the manual for more
-information.
+** module-filename field and accessor
-** Faster VM hooks.
+Modules now record the file in which they are defined. This field may be
+accessed with the new `module-filename' procedure.
-The frame objects passed to VM hook procedures are now allocated on the
-stack instead of the heap, making the next-instruction hook practical to
-use.
+** call-with-error-handling / with-error-handling
-** New `eval-when' situation: `expand'
+FIXME: document?
-Sometimes it's important to cause side-effects while expanding an
-expression, even in eval mode. This situation is used in
-`define-module', `use-modules', et al, in order to affect the current
-module and its set of syntax expanders.
+** Deprecate the old scm-style-repl
-** Better module-level hygiene
+The following bindings from boot-9 are now found in `(ice-9
+scm-style-repl)': `scm-style-repl', `error-catching-loop',
+`error-catching-repl', `bad-throw', `scm-repl-silent'
+`assert-repl-silence', `repl-print-unspecified',
+`assert-repl-print-unspecified', `scm-repl-verbose',
+`assert-repl-verbosity', `scm-repl-prompt', `set-repl-prompt!', `repl',
+`default-pre-unwind-handler', `handle-system-error',
-Instead of attempting to track changes to the current module when
-expanding toplevel sequences, we instead preserve referential
-transparency relative to where the macro itself was defined. If the
-macro should expand to expressions in the context of the new module, it
-should wrap those expressions in `@@', which has been enhanced to accept
-generic expressions, not just identifier references. For example, part
-of the definition of the R6RS `library' form:
+The following bindings have been deprecated, with no replacement:
+`pre-unwind-handler-dispatch'.
- #'(begin
- (define-module (name name* ...) #:pure #:version (version ...))
- (import ispec) ...
- (re-export r ...) (export e ...)
- (@@ (name name* ...) body)
- ...)
+The following bindings have been totally removed:
+`before-signal-stack'.
+
+Deprecated forwarding shims have been installed so that users that
+expect these bindings in the main namespace will still work, but receive
+a deprecation warning.
+
+** Miscellaneous other deprecations
+
+`apply-to-args', `has-suffix?', `scheme-file-suffix'
+`get-option', `for-next-option', `display-usage-report',
+`transform-usage-lambda', `collect', `set-batch-mode?!'
+
+** All core defmacros reimplemented hygienically
+
+All macros present in the default environment are now implemented with
+syntax-case. This should not have practical ramifications, beyond those
+listed below in "Lexical bindings introduced by hygienic macros may not
+be referenced by nonhygienic macros".
+
+** Random generator state may be serialized to a datum
+
+`random-state->datum' will serialize a random state to a datum, which
+may be written out, read back in later, and revivified using
+`datum->random-state'. See "Random" in the manual, for more details.
-In this example the `import' refers to the `import' definition in the
-module where the `library' macro is defined, not in the new module.
+** New primitive: `tmpfile'.
+
+See "File System" in the manual.
+
+** Modules load within a known environment
+
+It takes a few procedure calls to define a module, and those procedure
+calls need to be in scope. Now we ensure that the current module when
+loading a module is one that has the needed bindings, instead of relying
+on chance.
+
+** Remove encoding of versions into the file system
-** Module system macros rewritten as hygienic macros
+It used to be that, when loading a module, if the user specified a
+version, Guile would grovel about in the filesystem to find the
+module. This process was slow and not robust. This support has been
+removed: modules are once more always loaded via `primitive-load-path'.
-`define-module', `use-modules', `export', and other such macros have
-been rewritten as hygienic macros. This allows the necessary referential
-transparency for the R6RS `library' form to do the right thing.
+Module versions in the filesystem may be added again in the future, in
+an extensible way. Contact address@hidden with patches.
-** Compiler and VM documentation updated
+** Alex Shinn's pattern matcher for (ice-9 match).
+
+Guile's copy of Andrew K. Wright's `match' library has been replaced by
+a compatible hygienic implementation by Alex Shinn.
+
+Compared to Andrew K. Wright's `match', the new `match' lacks
+`match-define', `match:error-control', `match:set-error-control',
+`match:error', `match:set-error', and all structure-related procedures.
-The documentation for the compiler and VM had slipped out of date; it
-has been brought back... to the future!
+** Better debugging for psyntax
-** Tree-IL field renaming: `vars' -> `gensyms'
+We now build psyntax-pp.go directly from psyntax.scm, which allows us to
+preserve the original source locations and variable names. Git users
+will also be please to note that psyntax-pp.scm is no longer
+automatically regenerated from a normal `make' invocation.
-The `vars' fields of <let>, <letrec>, <fix>, and <lambda-case> has been
-renamed to `gensyms', for clarity, and to match <lexical-ref>.
+** AM_SILENT_RULES
-** Removed `version' field from <language>
+Guile's build is visually quieter, due to the use of Automake 1.11's
+AM_SILENT_RULES. Build as `make V=1' to see all of the output.
-Language versions weren't being updated or used in any worthwhile way;
-they have been removed, for now at least.
+** Better REPL options interface
-** New procedure: `module-export-all!'
+The set of REPL options is now fixed and typechecked -- you can't
+mistakenly set an option that doesn't exist, or set an value with an
+incorrect type. The following options have been added: `prompt',
+`compile-options', and `value-history'.
-This procedure exports all current and future bindings from a module.
-Use as `(module-export-all! (current-module))'.
+The new `repl-default-option-set!' procedure from `(system repl common)'
+can set default options for future REPLs. `repl-default-prompt-set!' is
+a convenience procedure to set default prompts.
+
+** `*unspecified*' is identifier syntax
-** Updates to manual
+`*unspecified*' is no longer a variable, so it is optimized properly by
+the compiler, and is not `set!'-able.
-The introductory sections of the manual have been reorganized
-significantly, making it more accessible to new users of Guile. Check it
-out!
+** `set-batch-mode?!' replaced by `ensure-batch-mode!'
-** The module namespace is now separate from the value namespace
+"Batch mode" is a flag used to tell a program that it is not running
+interactively. One usually turns it on after a fork. It may not be
+turned off. `ensure-batch-mode!' deprecates the old `set-batch-mode?!',
+because it is a better interface, as it can only turn on batch mode, not
+turn it off.
-It was a little-known implementation detail of Guile's module system
-that it was built on a single hierarchical namespace of values -- that
-if there was a module named `(foo bar)', then in the module named
-`(foo)' there was a binding from `bar' to the `(foo bar)' module.
+** `(debug)' gone (fix?)
+
+ * module/system/vm/debug.scm (debug): Change to debug the current stack
+ instead of the last stack.
-This was a neat trick, but presented a number of problems. One problem
-was that the bindings in a module were not apparent from the module
-itself; perhaps the `(foo)' module had a private binding for `bar', and
-then an external contributor defined `(foo bar)'. In the end there can
-be only one binding, so one of the two will see the wrong thing, and
-produce an obtuse error of unclear provenance.
+** Support for settable identifier syntax
-Also, the public interface of a module was also bound in the value
-namespace, as `%module-public-interface'. This was a hack from the early
-days of Guile's modules.
+Following the R6RS, "variable transformers" are settable
+identifier-syntax. See "Identifier macros" in the manual, for more
+information.
+
+** Deprecate `save-stack', `the-last-stack'
-Both of these warts have been fixed by the addition of fields in the
-`module' data type. Access to modules and their interfaces from the
-value namespace has been deprecated, and all accessors use the new
-record accessors appropriately.
+It used to be that the way to debug programs in Guile was to capture the
+stack at the time of error, drop back to the REPL, then debug that
+stack. But this approach didn't compose, was tricky to get right in the
+presence of threads, and was not very powerful.
-When Guile is built with support for deprecated code, as is the default,
-the value namespace is still searched for modules and public interfaces,
-and a deprecation warning is raised as appropriate.
+So `save-stack', `stack-saved?', and `the-last-stack' have been moved to
+`(ice-9 save-stack)', with deprecated bindings left in the root module.
-Finally, to support lazy loading of modules as one used to be able to do
-with module binder procedures, Guile now has submodule binders, called
-if a given submodule is not found. See boot-9.scm for more information.
+** Compilation warnings at the REPL
-** New procedures: module-ref-submodule, module-define-submodule,
- nested-ref-module, nested-define-module!, local-ref-module,
- local-define-module
+By default, Guile now prints compile-time warnings for code entered at
+the REPL. Current warnings are for unbound variables and mismatched
+arities.
-These new accessors are like their bare variants, but operate on
-namespaces instead of values.
+** syntax-case treats `_' as a placeholder
+
+Following R6RS, a `_' in a syntax-rules or syntax-case pattern matches
+anything, and binds no pattern variables. Unlike the R6RS, Guile also
+permits `_' to be in the literals list for a pattern.
-** The (app modules) module tree is officially deprecated
+** Remove old Emacs interface
-It used to be that one could access a module named `(foo bar)' via
-`(nested-ref the-root-module '(app modules foo bar))'. The `(app
-modules)' bit was a never-used and never-documented abstraction, and has
-been deprecated. See the following mail for a full discussion:
+Guile had an unused `--emacs' command line argument that was supposed to
+help when running Guile inside Emacs. This option has been removed, and
+the helper functions `named-module-use!' and `load-emacs-interface' have
+been deprecated.
+
+** `top-repl' has its own module
+
+The `top-repl' binding, called with Guile is run interactively, is now
+is its own module, `(ice-9 top-repl)'. A deprecated forwarding shim was
+left in the default environment.
- http://lists.gnu.org/archive/html/guile-devel/2010-04/msg00168.html
+** Value history in the REPL on by default
-The `%app' binding is also deprecated.
+By default, the REPL will save computed values in variables like `$1',
+`$2', and the like. There are programmatic and interactive interfaces to
+control this. See "Value History" in the manual, for more information.
-** Deprecated address@hidden' syntax
+** New threads are in `(guile-user)' by default, not `(guile)'
address@hidden' was part of an older implementation of the Emacs Lisp language,
-and is no longer used.
-
-** New fluid: `%file-port-name-canonicalization'
+It used to be that a new thread entering Guile would do so in the
+`(guile)' module, unless this was the first time Guile was initialized,
+in which case it was `(guile-user)'. This has been fixed to have all
+new threads unknown to Guile default to `(guile-user)'.
+
+** Backtrace improvements
+
+It used to be that backtraces showed a couple of extra frames, from the
+implementation of prompts. This has been fixed. Also, backtraces now
+print column numbers in addition to line numbers, if possible.
+
+** `display-error' takes a frame
+
+The `display-error' / `scm_display_error' helper now takes a frame as an
+argument instead of a stack. Stacks are still supported in deprecated
+builds. Additionally, `display-error' will again source location
+information for the error.
+
+** Better error reporting from the VM
-This fluid parameterizes the file names that are associated with file
-ports. If %file-port-name-canonicalization is 'absolute, then file names
-are canonicalized to be absolute paths. If it is 'relative, then the
-name is canonicalized, but any prefix corresponding to a member of
-`%load-path' is stripped off. Otherwise the names are passed through
-unchanged.
+If a value of the wrong type is passed to `car', `cdr', `set-car!',
+`set-cdr!', `apply', a struct accessor, or a bytevector accessors, the
+error from the VM now indicates which procedure failed, instead of
+lumping them all into the non-helpful "VM error". In addition, unbound
+variable reporting is now more helpful.
-** Source file name canonicalization in `compile-file', `compile-and-load'
+** No more `(ice-9 debug)'
-These file-compiling procedures now bind
-%file-port-name-canonicalization to their `#:canonicalization' keyword
-argument, which defaults to 'relative. In this way, one might compile
-"../module/ice-9/boot-9.scm", but the path that gets residualized into
-the .go is "ice-9/boot-9.scm".
+This module had some debugging helpers that are no longer applicable to
+the current debugging model. Importing this module will produce a
+deprecation warning. Users should contact bug-guile for support.
-** Deprecate arity access via (procedure-properties proc 'arity)
+** No more `(system vm debug)'
-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
-accessor.
+This module is replaced by the recursive debugging REPL.
+
+** File ports handle binary mode and coding declarations
+
+Binary file ports are supported again, by opening files in the
+ISO-8859-1 encoding. If an encoding is not specified for textual ports,
+Guile now grovels the file for a "coding:" directive, and uses that if
+possible. See the documentation for `open-file', for more information.
+
+** R6RS character hex escapes on by default
+
+However, R6RS character escapes within strings are incompatible with
+older Guile escape sequences, so they still need the reader option
+turned on. See "Reader Options" in the manual, for more information.
-** Remove redundant accessors: program-name, program-documentation,
- program-properties, program-property
+** Fix random number generator on 64-bit platforms
-Instead, just use procedure-name, procedure-documentation,
-procedure-properties, and procedure-property.
+There was a nasty bug on 64-bit platforms in which asking for a random
+integer with a range between 2**32 and 2**64 caused a segfault. After
+many embarrassing iterations, this was fixed.
-** Enhance documentation for support of Emacs Lisp's `nil'
+** Add `vhash-fold*' in `(ice-9 vlist)'.
-See "Nil" in the manual, for more details.
+See "VLists" in the manual, for more information.
+
+** Timestamps on autocompiled files checked for freshness, not equality
-** Enhance documentation for support of other languages
+It used to be that to load a `.go' file instead of a `.scm' file, we
+required that the timestamp of the `.go' file be equal to that of the
+`.scm'. This has been relaxed to accept newer `.go' files, to integrate
+better with `make' tools.
+
+** Simplifications to the `(system foreign)' API.
+
+Guile's foreign function interface was simplified a great
+deal. Interested users should see "Foreign Function Interface" in the
+manual, for full details.
+
+** User Scheme code may be placed in a version-specific path
-See "Other Languages" in the manual, for more details.
+Before, there was only one way to install user Scheme code to a
+version-specific Guile directory: install to Guile's own path,
+e.g. /usr/share/guile/2.0. The site directory,
+e.g. /usr/share/guile/site, was unversioned. This has been changed to
+add a version-specific site directory, e.g. /usr/share/guile/site/2.0,
+searched before the global site directory.
** And of course, the usual collection of bugfixes
@@ -269,6 +357,9 @@ Changes in 1.9.x (since the 1.8.x series):
** `(system xref)', a cross-referencing facility (FIXME undocumented)
** `(ice-9 vlist)', lists with constant-time random access; hash lists
** `(system foreign)', foreign function interface
+** `(sxml match)', a pattern matcher for SXML
+** `(srfi srfi-9 gnu)', extensions to the SRFI-9 record library
+** `(system vm coverage)', a line-by-line code coverage library
** Imported statprof, SSAX, and texinfo modules from Guile-Lib
@@ -365,6 +456,33 @@ warranty disclaimer on startup, along with pointers to
more information.
* Changes to Scheme functions and syntax
+** Support for R6RS libraries
+
+The `library' and `import' forms from the latest Scheme report have been
+added to Guile, in such a way that R6RS libraries share a namespace with
+Guile modules. R6RS modules may import Guile modules, and are available
+for Guile modules to import via use-modules and all the rest. See "R6RS
+Libraries" in the manual for more information.
+
+** Implementations of R6RS libraries
+
+Guile now has implementations for all of the libraries defined in the
+R6RS. Thanks to Julian Graham for this excellent hack. See "R6RS
+Standard Libraries" in the manual for a full list of libraries.
+
+** Partial R6RS compatibility
+
+Guile now has enough support for R6RS to run a reasonably large subset
+of R6RS programs.
+
+Guile is not fully R6RS compatible. Many incompatibilities are simply
+bugs, though some parts of Guile will remain R6RS-incompatible for the
+foreseeable future. See "R6RS Incompatibilities" in the manual, for more
+information.
+
+Please contact address@hidden if you have found an issue not
+mentioned in that compatibility list.
+
** New implementation of `primitive-eval'
Guile's `primitive-eval' is now implemented in Scheme. Actually there is
@@ -552,6 +670,11 @@ export, it now also accepts a pair of symbols, indicating
that a binding
should be renamed on export. See "Creating Guile Modules" in the manual
for more information.
+** New procedure: `module-export-all!'
+
+This procedure exports all current and future bindings from a module.
+Use as `(module-export-all! (current-module))'.
+
** `eval-case' has been deprecated, and replaced by `eval-when'.
The semantics of `eval-when' are easier to understand. See "Eval When"
@@ -575,6 +698,19 @@ feedback about this change (a consequence of using psyntax
as the
default expander), and may choose to revisit this situation before 2.0
in response to user feedback.
+** Macro expansion produces structures instead of s-expressions
+
+In the olden days, macroexpanding an s-expression would yield another
+s-expression. Though the lexical variables were renamed, expansions of
+core forms like `if' and `begin' were still non-hygienic, as they relied
+on the toplevel definitions of `if' et al being the conventional ones.
+
+The solution is to expand to structures instead of s-expressions. There
+is an `if' structure, a `begin' structure, a `toplevel-ref' structure,
+etc. The expander already did this for compilation, producing Tree-IL
+directly; it has been changed now to do so when expanding for the
+evaluator as well.
+
** Defmacros must now produce valid Scheme expressions.
It used to be that defmacros could unquote in Scheme values, as a way of
@@ -734,6 +870,55 @@ because of hygiene and macros, all modules have names. If
a module was
created without a name, the first time `module-name' is called on it, a
fresh name will be lazily generated for it.
+** The module namespace is now separate from the value namespace
+
+It was a little-known implementation detail of Guile's module system
+that it was built on a single hierarchical namespace of values -- that
+if there was a module named `(foo bar)', then in the module named
+`(foo)' there was a binding from `bar' to the `(foo bar)' module.
+
+This was a neat trick, but presented a number of problems. One problem
+was that the bindings in a module were not apparent from the module
+itself; perhaps the `(foo)' module had a private binding for `bar', and
+then an external contributor defined `(foo bar)'. In the end there can
+be only one binding, so one of the two will see the wrong thing, and
+produce an obtuse error of unclear provenance.
+
+Also, the public interface of a module was also bound in the value
+namespace, as `%module-public-interface'. This was a hack from the early
+days of Guile's modules.
+
+Both of these warts have been fixed by the addition of fields in the
+`module' data type. Access to modules and their interfaces from the
+value namespace has been deprecated, and all accessors use the new
+record accessors appropriately.
+
+When Guile is built with support for deprecated code, as is the default,
+the value namespace is still searched for modules and public interfaces,
+and a deprecation warning is raised as appropriate.
+
+Finally, to support lazy loading of modules as one used to be able to do
+with module binder procedures, Guile now has submodule binders, called
+if a given submodule is not found. See boot-9.scm for more information.
+
+** New procedures: module-ref-submodule, module-define-submodule,
+ nested-ref-module, nested-define-module!, local-ref-module,
+ local-define-module
+
+These new accessors are like their bare variants, but operate on
+namespaces instead of values.
+
+** The (app modules) module tree is officially deprecated
+
+It used to be that one could access a module named `(foo bar)' via
+`(nested-ref the-root-module '(app modules foo bar))'. The `(app
+modules)' bit was a never-used and never-documented abstraction, and has
+been deprecated. See the following mail for a full discussion:
+
+ http://lists.gnu.org/archive/html/guile-devel/2010-04/msg00168.html
+
+The `%app' binding is also deprecated.
+
** Many syntax errors have different texts now
Syntax errors still throw to the `syntax-error' key, but the arguments
@@ -862,9 +1047,10 @@ But this does not:
It is not normal to run into this situation with existing code. However,
as code is ported over from defmacros to syntax-case, it is possible to
-run into situations like this. In the future, Guile will probably port
-its `while' macro to syntax-case, which makes this issue one to know
-about.
+run into situations like this. For example, if you have a defmacro that
+generates a `while' expression, the `break' bound by the `while' may not
+be visible within other parts of your defmacro. The solution is to port
+from defmacros to syntax-rules or syntax-case.
** Macros may no longer be referenced as first-class values.
@@ -895,6 +1081,13 @@ arities of compiled procedures may be accessed via
procedures from the
`(system vm program)' module; see "Compiled Procedures", "Optional
Arguments", and "Case-lambda" in the manual.
+** Deprecate arity access via (procedure-properties proc 'arity)
+
+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
+accessor.
+
** `lambda*' and `define*' are now available in the default environment
As with `case-lambda', `(ice-9 optargs)' continues to be supported, for
@@ -1152,6 +1345,21 @@ backtrace. This has been fixed.
These are analogous to %load-path and %load-extensions.
+** New fluid: `%file-port-name-canonicalization'
+
+This fluid parameterizes the file names that are associated with file
+ports. If %file-port-name-canonicalization is 'absolute, then file names
+are canonicalized to be absolute paths. If it is 'relative, then the
+name is canonicalized, but any prefix corresponding to a member of
+`%load-path' is stripped off. Otherwise the names are passed through
+unchanged.
+
+In addition, the `compile-file' and `compile-and-load' procedures bind
+%file-port-name-canonicalization to their `#:canonicalization' keyword
+argument, which defaults to 'relative. In this way, one might compile
+"../module/ice-9/boot-9.scm", but the path that gets residualized into
+the .go is "ice-9/boot-9.scm".
+
** New procedure, `make-promise'
`(make-promise (lambda () foo))' is equivalent to `(delay foo)'.
@@ -1192,6 +1400,11 @@ respectively.
crazy. Please change to use `catch', possibly with a throw-handler, or
`with-throw-handler'.
+** Deprecated address@hidden' syntax
+
address@hidden' was part of an older implementation of the Emacs Lisp language,
+and is no longer used.
+
** Last but not least, the `λ' macro can be used in lieu of `lambda'
* Changes to the C interface
@@ -1374,6 +1587,10 @@ procedure, then return a specialized "call" procedure.
However this
optimization wasn't actually an optimization, so it is now deprecated.
Just use `scm_call_0', etc instead.
+** Deprecated `scm_badargsp'
+
+This function is unused in Guile, but was part of its API.
+
** Better support for Lisp `nil'.
The bit representation of `nil' has been tweaked so that it is now very
@@ -1460,7 +1677,7 @@ environments.
Before, Guile only searched the system library paths for extensions
(e.g. /usr/lib), which meant that the names of Guile extensions had to
be globally unique. Installing them to a Guile-specific extensions
-directory is cleaner. Use `pkg-config --variable=extensionsdir
+directory is cleaner. Use `pkg-config --variable=extensiondir
guile-2.0' to get the location of the extensions directory.
** New dependency: libgc
diff --git a/README b/README
index 90914e1..f216d7d 100644
--- a/README
+++ b/README
@@ -145,10 +145,6 @@ switches specific to Guile you may find useful in some
circumstances.
implementation and helps to keep Guile reasonably clean of historic
baggage.
- Deprecated features are considered harmful; using them is likely a
- bug. See below for the related notion of `discouraged' features,
- which are OK but have fallen out of favor.
-
See the file NEWS for a list of features that are currently
deprecated. Each entry will also tell you what you should replace
your code with.
@@ -198,16 +194,9 @@ switches specific to Guile you may find useful in some
circumstances.
'warn-deprecated) to enable and disable the detailed messaged at run
time.
---disable-discouraged
-
- In addition to deprecated features, Guile can also contain things
- that are merely `discouraged'. It is OK to continue to use these
- features in old code, but new code should avoid them since there are
- better alternatives.
-
- There is nothing wrong with a discouraged feature per se, but they
- might have strange names, or be non-standard, for example. Avoiding
- them will make your code better.
+ Additionally, if your toolchain is new enough, you will receive
+ warnings at link time if you have a Guile extension that uses
+ deprecated functions provided by Guile.
--disable-shared --- Do not build shared libraries.
--disable-static --- Do not build static libraries.
diff --git a/am/guilec b/am/guilec
index 824f105..7e34719 100644
--- a/am/guilec
+++ b/am/guilec
@@ -11,24 +11,13 @@ EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
CLEANFILES = $(GOBJECTS)
-# Well, shit. We can't have install changing timestamps, can we? But
-# install_sh doesn't know how to preserve timestamps. Soooo, fondle
-# automake to make things happen.
-install-data-hook:
- @$(am__vpath_adj_setup) \
- list='$(nobase_mod_DATA)'; for p in $$list; do \
- if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
- $(am__vpath_adj) \
- echo " touch -r '$$d$$p' '$(DESTDIR)$(moddir)/$$f'"; \
- touch -r "$$d$$p" "$(DESTDIR)$(moddir)/$$f"; \
- done
- @$(am__vpath_adj_setup) \
- list='$(nobase_ccache_DATA)'; for p in $$list; do \
- if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
- $(am__vpath_adj) \
- echo " touch -r '$$d$$p' '$(DESTDIR)$(ccachedir)/$$f'"; \
- touch -r "$$d$$p" "$(DESTDIR)$(ccachedir)/$$f"; \
- done
+# Make sure source files are installed first, so that the mtime of
+# installed compiled files is greater than that of installed source
+# files. See
+# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
+# for details.
+guile_install_go_files = install-nobase_ccacheDATA
+$(guile_install_go_files): install-nobase_modDATA
AM_V_GUILEC = $(AM_V_GUILEC_$(V))
AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY))
diff --git a/configure.ac b/configure.ac
index 57ba8d6..f3afec3 100644
--- a/configure.ac
+++ b/configure.ac
@@ -130,15 +130,6 @@ AC_ARG_ENABLE(regex,
[ --disable-regex omit regular expression interfaces],,
enable_regex=yes)
-AC_ARG_ENABLE([discouraged],
- AS_HELP_STRING([--disable-discouraged],[omit discouraged features]))
-
-if test "$enable_discouraged" = no; then
- SCM_I_GSC_ENABLE_DISCOURAGED=0
-else
- SCM_I_GSC_ENABLE_DISCOURAGED=1
-fi
-
AC_ARG_ENABLE([deprecated],
AS_HELP_STRING([--disable-deprecated],[omit deprecated features]))
@@ -1613,7 +1604,6 @@ AC_SUBST([sitedir])
# Additional SCM_I_GSC definitions are above.
AC_SUBST([SCM_I_GSC_GUILE_DEBUG])
-AC_SUBST([SCM_I_GSC_ENABLE_DISCOURAGED])
AC_SUBST([SCM_I_GSC_ENABLE_DEPRECATED])
AC_SUBST([SCM_I_GSC_STACK_GROWS_UP])
AC_SUBST([SCM_I_GSC_C_INLINE])
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index f415eeb..beeba0f 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -61,7 +61,7 @@ guile_TEXINFOS = preface.texi \
sxml-match.texi \
scheme-scripts.texi \
api-overview.texi \
- api-discdepr.texi \
+ api-deprecated.texi \
scheme-debugging.texi \
scheme-using.texi \
indices.texi \
diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi
index c5d5659..60af456 100644
--- a/doc/ref/api-binding.texi
+++ b/doc/ref/api-binding.texi
@@ -1,14 +1,12 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Binding Constructs
@section Definitions and Variable Bindings
address@hidden FIXME::martin: Review me!
-
Scheme supports the definition of variables in different contexts.
Variables can be defined at the top level, so that they are visible in
the entire program, and variables can be defined locally to procedures
@@ -27,8 +25,7 @@ and expressions. This is important for modularity and data
abstraction.
@cindex variable definition
-On the top level of a program (i.e. when not inside the body of a
-procedure definition or a @code{let}, @code{let*} or @code{letrec}
+At the top level of a program (i.e., not nested within any other
expression), a definition of the form
@lisp
@@ -38,10 +35,10 @@ expression), a definition of the form
@noindent
defines a variable called @code{a} and sets it to the value @var{value}.
-If the variable already exists, because it has already been created by a
-previous @code{define} expression with the same name, its value is
-simply changed to the new @var{value}. In this case, then, the above
-form is completely equivalent to
+If the variable already exists in the current module, because it has
+already been created by a previous @code{define} expression with the
+same name, its value is simply changed to the new @var{value}. In this
+case, then, the above form is completely equivalent to
@lisp
(set! a @var{value})
@@ -95,27 +92,23 @@ Attention: Scheme definitions inside local binding
constructs
@node Local Bindings
@subsection Local Variable Bindings
address@hidden FIXME::martin: Review me!
-
@cindex local bindings
@cindex local variables
-As opposed to definitions at the top level, which are visible in the
-whole program (or current module, when Guile modules are used), it is
-also possible to define variables which are only visible in a
-well-defined part of the program. Normally, this part of a program
-will be a procedure or a subexpression of a procedure.
+As opposed to definitions at the top level, which creates bindings that
+are visible to all code in a module, it is also possible to define
+variables which are only visible in a well-defined part of the program.
+Normally, this part of a program will be a procedure or a subexpression
+of a procedure.
-With the constructs for local binding (@code{let}, @code{let*} and
address@hidden), the Scheme language has a block structure like most
-other programming languages since the days of @sc{Algol 60}. Readers
-familiar to languages like C or Java should already be used to this
-concept, but the family of @code{let} expressions has a few properties
-which are well worth knowing.
+With the constructs for local binding (@code{let}, @code{let*},
address@hidden, and @code{letrec*}), the Scheme language has a block
+structure like most other programming languages since the days of
address@hidden 60}. Readers familiar to languages like C or Java should
+already be used to this concept, but the family of @code{let}
+expressions has a few properties which are well worth knowing.
-The first local binding construct is @code{let}. The other constructs
address@hidden and @code{letrec} are specialized versions for usage where
-using plain @code{let} is a bit inconvenient.
+The most basic local binding construct is @code{let}.
@deffn syntax let bindings body
@var{bindings} has the form
@@ -143,15 +136,16 @@ The values of the @var{init} expressions are stored into
the variables.
The expressions in @var{body} are evaluated in order, and the value of
the last expression is returned as the value of the @code{let}
expression.
-
address@hidden
-The storage for the @var{variables} is freed.
@end itemize
The @var{init} expressions are not allowed to refer to any of the
@var{variables}.
@end deffn
+The other binding contructs are variations on the same theme: making new
+values, binding them to variables, and executing a body in that new,
+extended lexical context.
+
@deffn syntax let* bindings body
Similar to @code{let}, but the variable bindings are performed
sequentially, that means that all @var{init} expression are allowed to
@@ -177,20 +171,45 @@ procedures created in the @var{init} expression can
recursively refer to
the defined variables.
@lisp
-(letrec ((even?
- (lambda (n)
- (if (zero? n)
- #t
- (odd? (- n 1)))))
- (odd?
- (lambda (n)
- (if (zero? n)
- #f
- (even? (- n 1))))))
+(letrec ((even? (lambda (n)
+ (if (zero? n)
+ #t
+ (odd? (- n 1)))))
+ (odd? (lambda (n)
+ (if (zero? n)
+ #f
+ (even? (- n 1))))))
(even? 88))
@result{}
#t
@end lisp
+
+Note that while the @var{init} expressions may refer to the new
+variables, they may not access their values. For example, making the
address@hidden function above creates a closure (@pxref{About Closure})
+referencing the @code{odd?} variable. But @code{odd?} can't be called
+until after execution has entered the body.
address@hidden deffn
+
address@hidden syntax letrec* bindings body
+Similar to @code{letrec}, except the @var{init} expressions are bound to
+their variables in order.
+
address@hidden thus relaxes the letrec restriction, in that later
address@hidden expressions may refer to the values of previously bound
+variables.
+
address@hidden
+(letrec ((a 42)
+ (b (+ a 10)))
+ (* a b))
address@hidden ;; Error: unbound variable: a
+
+(letrec* ((a 42)
+ (b (+ a 10)))
+ (* a b))
address@hidden 2184
address@hidden lisp
@end deffn
There is also an alternative form of the @code{let} form, which is used
@@ -204,11 +223,11 @@ iteration (@pxref{while do, Iteration})
@c FIXME::martin: Review me!
A @code{define} form which appears inside the body of a @code{lambda},
address@hidden, @code{let*}, @code{letrec} or equivalent expression is
-called an @dfn{internal definition}. An internal definition differs
-from a top level definition (@pxref{Top Level}), because the definition
-is only visible inside the complete body of the enclosing form. Let us
-examine the following example.
address@hidden, @code{let*}, @code{letrec}, @code{letrec*} or equivalent
+expression is called an @dfn{internal definition}. An internal
+definition differs from a top level definition (@pxref{Top Level}),
+because the definition is only visible inside the complete body of the
+enclosing form. Let us examine the following example.
@lisp
(let ((frumble "froz"))
@@ -222,11 +241,11 @@ peach
Here the enclosing form is a @code{let}, so the @code{define}s in the
@code{let}-body are internal definitions. Because the scope of the
internal definitions is the @strong{complete} body of the
address@hidden, the @code{lambda}-expression which gets bound
-to the variable @code{banana} may refer to the variable @code{apple},
-even though it's definition appears lexically @emph{after} the definition
-of @code{banana}. This is because a sequence of internal definition
-acts as if it were a @code{letrec} expression.
address@hidden, the @code{lambda}-expression which gets bound to
+the variable @code{banana} may refer to the variable @code{apple}, even
+though its definition appears lexically @emph{after} the definition of
address@hidden This is because a sequence of internal definition acts
+as if it were a @code{letrec*} expression.
@lisp
(let ()
@@ -240,29 +259,36 @@ is equivalent to
@lisp
(let ()
- (letrec ((a 1) (b 2))
+ (letrec* ((a 1) (b 2))
(+ a b)))
@end lisp
+Internal definitions are only allowed at the beginning of the body of an
+enclosing expression. They may not be mixed with other expressions.
+
Another noteworthy difference to top level definitions is that within
one group of internal definitions all variable names must be distinct.
That means where on the top level a second define for a given variable
acts like a @code{set!}, an exception is thrown for internal definitions
with duplicate bindings.
address@hidden FIXME::martin: The following is required by R5RS, but Guile does
not
address@hidden signal an error. Document it anyway, saying that Guile is
sloppy?
+As a historical note, it used to be that internal bindings were expanded
+in terms of @code{letrec}, not @code{letrec*}. This was the situation
+for the R5RS report and before. However with the R6RS, it was recognized
+that sequential definition was a more intuitive expansion, as in the
+following case:
address@hidden Internal definitions are only allowed at the beginning of the
body of an
address@hidden enclosing expression. They may not be mixed with other
expressions.
address@hidden
+(let ()
+ (define a 1)
+ (define b (+ a a))
+ (+ a b))
address@hidden lisp
+
address@hidden
+Guile decided to follow the R6RS in this regard, and now expands
+internal definitions using @code{letrec*}.
address@hidden @lisp
address@hidden (let ()
address@hidden (define a 1)
address@hidden a
address@hidden (define b 2)
address@hidden b)
address@hidden @end lisp
@node Binding Reflection
@subsection Querying variable bindings
@@ -275,11 +301,6 @@ top level environment.
Return @code{#t} if @var{sym} is defined in the module @var{module} or
the current module when @var{module} is not specified; otherwise return
@code{#f}.
-
-Up to Guile 1.8, the second optional argument had to be @dfn{lexical
-environment} as returned by @code{the-environment}, for example. The
-behavior of this function remains unchanged when the second argument is
-omitted.
@end deffn
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index cc11343..75e5e68 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -1511,9 +1511,13 @@ through @var{end} (exclusive) bits of @var{n}. The
@subsubsection Random Number Generation
Pseudo-random numbers are generated from a random state object, which
-can be created with @code{seed->random-state}. The @var{state}
-parameter to the various functions below is optional, it defaults to
-the state object in the @code{*random-state*} variable.
+can be created with @code{seed->random-state} or
address@hidden>random-state}. An external representation (i.e. one
+which can written with @code{write} and read with @code{read}) of a
+random state object can be obtained via
address@hidden>datum}. The @var{state} parameter to the
+various functions below is optional, it defaults to the state object
+in the @code{*random-state*} variable.
@deffn {Scheme Procedure} copy-random-state [state]
@deffnx {C Function} scm_copy_random_state (state)
@@ -1582,6 +1586,18 @@ Return a uniformly distributed inexact real random
number in
Return a new random state using @var{seed}.
@end deffn
address@hidden {Scheme Procedure} datum->random-state datum
address@hidden {C Function} scm_datum_to_random_state (datum)
+Return a new random state from @var{datum}, which should have been
+obtained by @code{random-state->datum}.
address@hidden deffn
+
address@hidden {Scheme Procedure} random-state->datum state
address@hidden {C Function} scm_random_state_to_datum (state)
+Return a datum representation of @var{state} that may be written out and
+read back with the Scheme reader.
address@hidden deffn
+
@defvar *random-state*
The global random state used by the above functions when the
@var{state} parameter is not given.
diff --git a/doc/ref/api-deprecated.texi b/doc/ref/api-deprecated.texi
new file mode 100644
index 0000000..ea18e4a
--- /dev/null
+++ b/doc/ref/api-deprecated.texi
@@ -0,0 +1,31 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010
address@hidden Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
+
address@hidden Deprecation
address@hidden Deprecation
+
+From time to time functions and other features of Guile become obsolete.
+Guile's @dfn{deprecation} is a mechanism that can help you cope with
+this.
+
+When you use a feature that is deprecated, you will likely get a
+warning message at run-time. Also, deprecated features are not ready
+for production use: they might be very slow.
+
+Additionally, if you have a new enough toolchain, using a deprecated
+function from @code{libguile} will cause a link-time warning.
+
+The primary source for information about just what things are deprecated
+in a given release is the file @file{NEWS}. That file also documents
+what you should use instead of the obsoleted things.
+
+The file @file{README} contains instructions on how to control the
+inclusion or removal of the deprecated features from the public API of
+Guile, and how to control the deprecation warning messages.
+
+The idea behind those mechanisms is that normally all deprecated are
+available, but you get feedback when compiling and running code that
+uses them, so that you can migrate to the newer APIs at your leisure.
diff --git a/doc/ref/api-discdepr.texi b/doc/ref/api-discdepr.texi
deleted file mode 100644
index ae6a685..0000000
--- a/doc/ref/api-discdepr.texi
+++ /dev/null
@@ -1,38 +0,0 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
address@hidden Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
-
address@hidden Discouraged and Deprecated
address@hidden Discouraged and Deprecated
-
-From time to time functions and other features of Guile become
-obsolete. Guile has some mechanisms in place that can help you cope
-with this.
-
-Guile has two levels of obsoleteness: things can be @emph{deprecated},
-meaning that their use is considered harmful and should be avoided,
-even in old code; or they can be merely @emph{discouraged}, meaning
-that they are fine in and of themselves, but that there are better
-alternatives that should be used in new code.
-
-When you use a feature that is deprecated, you will likely get a
-warning message at run-time. Also, deprecated features are not ready
-for production use: they might be very slow. When something is merely
-discouraged, it performs normally and you wont get any messages at
-run-time.
-
-The primary source for information about just what things are
-discouraged or deprecated in a given release is the file
address@hidden That file also documents what you should use instead
-of the obsoleted things.
-
-The file @file{README} contains instructions on how to control the
-inclusion or removal of the deprecated and/or discouraged features
-from the public API of Guile, and how to control the warning messages
-for deprecated features.
-
-The idea behind those mechanisms is that normally all deprecated and
-discouraged features are available, but that you can omit them on
-purpose to check whether your code still relies on them.
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 728c786..d7ff689 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -356,10 +356,24 @@ To define C primitives within a specific module, the
simplest way is:
(load-extension "foobar-c-code" "foo_bar_init")
@end example
address@hidden extensiondir
When loaded with @code{(use-modules (foo bar))}, the
@code{load-extension} call looks for the @file{foobar-c-code.so} (etc)
-object file in the standard system locations, such as @file{/usr/lib}
-or @file{/usr/local/lib}.
+object file in Guile's @code{extensiondir}, which is usually a
+subdirectory of the @code{libdir}. For example, if your libdir is
address@hidden/usr/lib}, the @code{extensiondir} for the Guile address@hidden
+series will be @file{/usr/lib/guile/2.0/}.
+
+The extension path includes the major and minor version of Guile (the
+``effective version''), because Guile guarantees compatibility within a
+given effective version. This allows you to install different versions
+of the same extension for different versions of Guile.
+
+If the extension is not found in the @code{extensiondir}, Guile will
+also search the standard system locations, such as @file{/usr/lib} or
address@hidden/usr/local/lib}. It is preferable, however, to keep your extension
+out of the system library path, to prevent unintended interference with
+other dynamically-linked C libraries.
If someone installs your module to a non-standard location then the
object file won't be found. You can address this by inserting the
@@ -377,7 +391,7 @@ can by substituted into a source file like @file{foo.scm.in}
@example
(define-module (foo bar))
-(load-extension "XXlibdirXX/foobar-c-code" "foo_bar_init")
+(load-extension "XXextensiondirXX/foobar-c-code" "foo_bar_init")
@end example
@noindent
@@ -386,17 +400,17 @@ with the following in a @file{Makefile}, using
@command{sed}
@example
foo.scm: foo.scm.in
- sed 's|XXlibdirXX|$(libdir)|' <foo.scm.in >foo.scm
+ sed 's|XXextensiondirXX|$(libdir)/guile/2.0|' <foo.scm.in >foo.scm
@end example
-The actual pattern @code{XXlibdirXX} is arbitrary, it's only something
+The actual pattern @code{XXextensiondirXX} is arbitrary, it's only something
which doesn't otherwise occur. If several modules need the value, it
can be easier to create one @file{foo/config.scm} with a define of the
address@hidden location, and use that as required.
address@hidden location, and use that as required.
@example
(define-module (foo config))
-(define-public foo-config-libdir "XXlibdirXX"")
+(define-public foo-config-extensiondir "XXextensiondirXX"")
@end example
Such a file might have other locations too, for instance a data
@@ -404,11 +418,6 @@ directory for auxiliary files, or @code{localedir} if the
module has
its own @code{gettext} message catalogue
(@pxref{Internationalization}).
-When installing multiple C code objects, it can be convenient to put
-them in a subdirectory of @code{libdir}, thus giving for example
address@hidden/usr/lib/foo/some-obj.so}. If the objects are only meant to be
-used through the module, then a subdirectory keeps them out of sight.
-
It will be noted all of the above requires that the Scheme code to be
found in @code{%load-path} (@pxref{Build Config}). Presently it's
left up to the system administrator or each user to augment that path
@@ -416,21 +425,6 @@ when installing Guile modules in non-default locations.
But having
reached the Scheme code, that code should take care of hitting any of
its own private files etc.
-Presently there's no convention for having a Guile version number in
-module C code filenames or directories. This is primarily because
-there's no established principles for two versions of Guile to be
-installed under the same prefix (eg. two both under @file{/usr}).
-Assuming upward compatibility is maintained then this should be
-unnecessary, and if compatibility is not maintained then it's highly
-likely a package will need to be revisited anyway.
-
-The present suggestion is that modules should assume when they're
-installed under a particular @code{prefix} that there's a single
-version of Guile there, and the @code{guile-config} at build time has
-the necessary information about it. C code or Scheme code might adapt
-itself accordingly (allowing for features not available in an older
-version for instance).
-
@node Foreign Pointers
@subsection Foreign Pointers
@@ -443,7 +437,7 @@ next discusses C functions.
@menu
* Foreign Types:: Expressing C types in Scheme.
-* Foreign Variables:: Typed pointers.
+* Foreign Variables:: Pointers to C symbols.
* Void Pointers and Byte Access:: Pointers into the ether.
* Foreign Structs:: Packing and unpacking structs.
@end menu
@@ -455,9 +449,9 @@ The first impedance mismatch that one sees between C and
Scheme is that
in C, the storage locations (variables) are typed, but in Scheme types
are associated with values, not variables. @xref{Values and Variables}.
-So when accessing a C value through a Scheme pointer, we must give the
-type of the pointed-to value explicitly, as a parameter to any Scheme
-procedure that accesses the value.
+So when describing a C function or a C structure so that it can be
+accessed from Scheme, the data types of the parameters or fields must be
+passed explicitly.
These ``C type values'' may be constructed using the constants and
procedures from the @code{(system foreign)} module, which may be loaded
@@ -480,8 +474,8 @@ C types:
@defvrx {Scheme Variable} int64
@defvrx {Scheme Variable} float
@defvrx {Scheme Variable} double
-Values exported by the @code{(system foreign)} module, representing C
-numeric types of the specified sizes and signednesses.
+These values represent the C numeric types of the specified sizes and
+signednesses.
@end defvr
In addition there are some convenience bindings for indicating types of
@@ -497,22 +491,22 @@ numeric types. For example, @code{long} may be
@code{equal?} to
@code{int64} on a 64-bit platform.
@end defvr
address@hidden {Scheme Variable} void
+The @code{void} type. It can be used as the first argument to
address@hidden to wrap a C function that returns nothing.
address@hidden defvr
+
@node Foreign Variables
@subsubsection Foreign Variables
-Given the types defined in the previous section, C pointers may be
-looked up dynamically using @code{dynamic-pointer}.
-
address@hidden {Scheme Procedure} dynamic-pointer name type dobj [len]
address@hidden {C Function} scm_dynamic_pointer (name, type, dobj, len)
-Return a ``handle'' for the pointer @var{name} in the shared object referred to
-by @var{dobj}. The handle aliases a C value, and is declared to be of type
address@hidden Valid types are defined in the @code{(system foreign)} module.
+Pointers to variables in the current address space may be looked up
+dynamically using @code{dynamic-pointer}.
-This facility works by asking the dynamic linker for the address of a symbol,
-then assuming that it aliases a value of a given type. Obviously, the user must
-be very careful to ensure that the value actually is of the declared type, or
-bad things will happen.
address@hidden {Scheme Procedure} dynamic-pointer name dobj
address@hidden {C Function} scm_dynamic_pointer (name, dobj)
+Return a ``wrapped pointer'' for the symbol @var{name} in the shared
+object referred to by @var{dobj}. The returned pointer points to a C
+object.
Regardless whether your C compiler prepends an underscore @samp{_} to the
global
names in a program, you should @strong{not} include this underscore in
@@ -525,98 +519,56 @@ pointing to that foreign value, we do:
@example
(use-modules (system foreign))
-(define numptob (dynamic-pointer "scm_numptob" long (dynamic-link)))
+(define numptob (dynamic-pointer "scm_numptob" (dynamic-link)))
numptob
address@hidden #<foreign int32 8>
address@hidden #<pointer 0x7fb35b1b4688>
@end example
-A value returned by @code{dynamic-pointer} is a Scheme wrapper for a C
-pointer, with additional type information. A foreign pointer prints
-according to its type. This example showed that a @code{long} on this
-platform is an @code{int32}, and that the value pointed to by
address@hidden is 8.
-
-Typed pointers may be referenced using the @code{foreign-ref} and
address@hidden functions.
+(The next section discusses ways to dereference pointers.)
address@hidden {Scheme Procedure} foreign-ref foreign
address@hidden {C Function} scm_foreign_ref foreign
-Reference the foreign value pointed to by @var{foreign}.
+A value returned by @code{dynamic-pointer} is a Scheme wrapper for a C
+pointer.
-The value will be referenced according to its type.
address@hidden {Scheme Procedure} pointer-address pointer
address@hidden {C Function} scm_pointer_address pointer
+Return the numerical value of @var{pointer}.
@example
-(foreign-ref numptob) @result{} 8 ; YMMV
+(pointer-address numptob)
address@hidden 139984413364296 ; YMMV
@end example
@end deffn
address@hidden {Scheme Procedure} foreign-set! foreign val
address@hidden {C Function} scm_foreign_set_x foreign val
-Set the foreign value pointed to by @var{foreign}.
address@hidden {Scheme Procedure} make-pointer address [finalizer]
+Return a foreign pointer object pointing to @var{address}. If
address@hidden is passed, it should be a pointer to a one-argument C
+function that will be called when the pointer object becomes
+unreachable.
address@hidden deffn
-The value will be set according to its type.
address@hidden {Scheme Variable} %null-pointer
+A foreign pointer whose value is 0.
address@hidden defvr
address@hidden
-(foreign-set! numptob 120) ; Don't try this at home!
address@hidden example
address@hidden {Scheme Procedure} null-pointer? pointer
+Return @code{#t} if @var{pointer} is the null pointer, @code{#f} otherwise.
@end deffn
-If we wanted to corrupt Guile's internal state, we could set
address@hidden to another value; but we shouldn't, because that
-variable is not meant to be set. Indeed this point applies more widely:
-the C API is a dangerous place to be. Not only might setting a value
-crash your program, simply referencing a value with a wrong-sized type
-can prove equally disastrous.
-
@node Void Pointers and Byte Access
@subsubsection Void Pointers and Byte Access
-As a special case, a dynamic pointer may be declared to point to type
address@hidden, in which case it is treated as a void pointer. A void
-pointer prints its value as a pointer, without dereferencing the
-pointer.
-
-It's important at this point to conceptually separate foreign values
-from foreign pointers. @code{dynamic-pointer} gives you a foreign
-pointer. A foreign value is the semantic meaning of the bytes pointed to
-by a pointer. Only foreign pointers may be wrapped in Scheme. One may
-make a pointer to a foreign value, and wrap that as a Scheme object, but
-a bare foreign value may not be wrapped.
+Wrapped pointers are untyped, so they are essentially equivalent to C
address@hidden pointers. As in C, the memory region pointed to by a
+pointer can be accessed at the byte level. This is achieved using
address@hidden (@pxref{Bytevectors}). The @code{(rnrs bytevector)}
+module contains procedures that can be used to convert byte sequences to
+Scheme objects such as strings, floating point numbers, or integers.
-When you call @code{dynamic-pointer}, the @var{type} argument indicates
-the type to which the given symbol points, but sometimes you don't know
-that type. Sometimes you have a pointer, and you don't know what kind of
-object it references. It's simply a pointer out into the ether, into the
address@hidden
-
-Guile can wrap such a pointer, by declaring that it points to
address@hidden
-
address@hidden {Scheme Variable} void
-A foreign type value representing nothing.
-
address@hidden has two uses: for a foreign pointer, declaring it to be of
-type @code{void} is like having a @code{void*} in C. For a function, a
-return type of @code{void} indicates that the function returns no
-values. A function argument type of @code{void} is invalid.
address@hidden defvr
-
-As an example, @code{(dynamic-pointer "foo" void bar-lib)} links in the
address@hidden symbol in the @var{bar-lib} library as a pointer to
address@hidden: a @code{void*}.
-
-Void pointers may be accessed as bytevectors.
-
address@hidden {Scheme Procedure} foreign->bytevector foreign [uvec_type
[offset [len]]]
address@hidden {C Function} scm_foreign_to_bytevector foreign uvec_type offset
len
-Return a bytevector aliasing the memory pointed to by
address@hidden
-
address@hidden must be a void pointer, a foreign whose type is
address@hidden By default, the resulting bytevector will alias
-all of the memory pointed to by @var{foreign}, from beginning
-to end, treated as a @code{vu8} array.
address@hidden {Scheme Procedure} pointer->bytevector pointer len [offset
[uvec_type]]
address@hidden {C Function} scm_foreign_to_bytevector pointer len offset
uvec_type
+Return a bytevector aliasing the @var{len} bytes pointed to by
address@hidden
The user may specify an alternate default interpretation for
the memory by passing the @var{uvec_type} argument, to indicate
@@ -625,28 +577,45 @@ that the memory is an array of elements of that type.
@code{uniform-vector-element-type} would return, like @code{f32}
or @code{s16}.
-Users may also specify that the bytevector should only alias a
-subset of the memory, by specifying @var{offset} and @var{len}
-arguments.
+When @var{offset} is passed, it specifies the offset in bytes relative
+to @var{pointer} of the memory region aliased by the returned
+bytevector.
Mutating the returned bytevector mutates the memory pointed to by
address@hidden, so buckle your seatbelts.
address@hidden, so buckle your seatbelts.
@end deffn
address@hidden {Scheme Procedure} bytevector->foreign bv [offset [len]]
address@hidden {C Function} scm_bytevector_to_foreign bv offset len
-Return a foreign pointer aliasing the memory pointed to by
address@hidden
address@hidden {Scheme Procedure} bytevector->pointer bv [offset]
address@hidden {C Function} scm_bytevector_to_pointer bv offset
+Return a pointer pointer aliasing the memory pointed to by @var{bv} or
address@hidden bytes after @var{bv} when @var{offset} is passed.
address@hidden deffn
-The resulting foreign will be a void pointer, a foreign whose
-type is @code{void}. By default it will alias all of the
-memory pointed to by @var{bv}, from beginning to end.
+In addition to these primitives, convenience procedures are available:
-Users may explicily specify that the foreign should only alias a
-subset of the memory, by specifying @var{offset} and @var{len}
-arguments.
address@hidden {Scheme Procedure} dereference-pointer pointer
+Assuming @var{pointer} points to a memory region that holds a pointer,
+return this pointer.
@end deffn
+Going back to the @code{scm_numptob} example above, here is how we can
+read its value as a C @code{long} integer:
+
address@hidden
+(use-modules (rnrs bytevectors))
+
+(bytevector-uint-ref (pointer->bytevector numptob (sizeof long))
+ 0 (native-endianness)
+ (sizeof long))
address@hidden 8
address@hidden example
+
+If we wanted to corrupt Guile's internal state, we could set
address@hidden to another value; but we shouldn't, because that
+variable is not meant to be set. Indeed this point applies more widely:
+the C API is a dangerous place to be. Not only might setting a value
+crash your program, simply accessing the data pointed to by a dangling
+pointer or similar can prove equally disastrous.
@node Foreign Structs
@subsubsection Foreign Structs
@@ -772,14 +741,16 @@ To invoke @code{memcpy}, one must pass it foreign
pointers:
@example
(use-modules (rnrs bytevectors))
+(define src-bits
+ (u8-list->bytevector '(0 1 2 3 4 5 6 7)))
(define src
- (bytevector->foreign (u8-list->bytevector '(0 1 2 3 4 5 6 7))))
+ (bytevector->pointer src-bits))
(define dest
- (bytevector->foreign (make-bytevector 16 0)))
+ (bytevector->pointer (make-bytevector 16 0)))
-(memcpy dest src (bytevector-length (foreign->bytevector src)))))
+(memcpy dest src (bytevector-length src-bits))
-(bytevector->u8-list (foreign->bytevector dest))
+(bytevector->u8-list (pointer->bytevector dest 16))
@result{} (0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0)
@end example
@@ -815,13 +786,6 @@ by the foreign pointer is mutated in place.
@result{} 499553
@end example
-This example also shows use of @code{%null-pointer}, which is a null
-foreign pointer, exported by @code{(system foreign)}.
-
address@hidden {Scheme Variable} %null-pointer
-A foreign pointer whose value is 0.
address@hidden defvr
-
As you can see, this interface to foreign functions is at a very low,
somewhat dangerous level. A contribution to Guile in the form of a
high-level FFI would be most welcome.
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 51f54ed..fba14f3 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -772,10 +772,68 @@ following to replace @code{fx+} with @code{+}:
(define-syntax fx+ (identifier-syntax +))
@end example
-Later versions of the @code{psyntax} @code{syntax-case} expander, on which
-Guile's syntax expander is based, include @code{identifier-syntax} support for
-recognizing identifiers on the left-hand side of a @code{set!} expression as
-well. Guile should port that code to its expander.
+There is also special support for recognizing identifiers on the
+left-hand side of a @code{set!} expression, as in the following:
+
address@hidden
+(define-syntax foo foo-transformer)
+(set! foo @var{val})
+;; expands via
+(foo-transformer #'(set! foo @var{val}))
+;; iff foo-transformer is a "variable transformer"
address@hidden example
+
+As the example notes, the transformer procedure must be explicitly
+marked as being a ``variable transformer'', as most macros aren't
+written to discriminate on the form in the operand position.
+
address@hidden {Scheme Procedure} make-variable-transformer transformer
+Mark the @var{transformer} procedure as being a ``variable
+transformer''. In practice this means that, when bound to a syntactic
+keyword, it may detect references to that keyword on the left-hand-side
+of a @code{set!}.
+
address@hidden
+(define bar 10)
+(define-syntax bar-alias
+ (make-variable-transformer
+ (lambda (x)
+ (syntax-case x (set!)
+ ((set! var val) #'(set! bar val))
+ ((var arg ...) #'(bar arg ...))
+ (var (identifier? #'var) #'bar)))))
+
+bar-alias @result{} 10
+(set! bar-alias 20)
+bar @result{} 20
+(set! bar 30)
+bar-alias @result{} 30
address@hidden example
address@hidden deffn
+
+There is an extension to identifer-syntax which allows it to handle the
address@hidden case as well:
+
address@hidden {Syntax} identifier-syntax (var exp1) ((set! var val) exp2)
+Create a variable transformer. The first clause is used for references
+to the variable in operator or operand position, and the second for
+appearances of the variable on the left-hand-side of an assignment.
+
+For example, the previous @code{bar-alias} example could be expressed
+more succinctly like this:
+
address@hidden
+(define-syntax bar-alias
+ (identifier-syntax
+ (var bar)
+ ((set! var val) (set! bar val))))
address@hidden example
+
address@hidden
+As before, the templates in @code{identifier-syntax} forms do not need
+wrapping in @code{#'} syntax forms.
address@hidden deffn
+
@node Eval When
@subsection Eval-when
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 1883099..494a676 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -441,10 +441,10 @@ original binding names, @var{gensyms} are gensyms
corresponding to the
@var{names}, and @var{vals} are Tree-IL expressions for the values.
@var{exp} is a single Tree-IL expression.
@end deftp
address@hidden {Scheme Variable} <letrec> src names gensyms vals exp
address@hidden {External Representation} (letrec @var{names} @var{gensyms}
@var{vals} @var{exp})
address@hidden {Scheme Variable} <letrec> in-order? src names gensyms vals exp
address@hidden {External Representation} (letrec @var{in-order?} @var{names}
@var{gensyms} @var{vals} @var{exp})
A version of @code{<let>} that creates recursive bindings, like
-Scheme's @code{letrec}.
+Scheme's @code{letrec}, or @code{letrec*} if @var{in-order?} is true.
@end deftp
@deftp {Scheme Variable} <dynlet> fluids vals body
@deftpx {External Representation} (dynlet @var{fluids} @var{vals} @var{body})
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 29b6570..c47dfc5 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -288,7 +288,7 @@ available through both Scheme and C interfaces.
@menu
* API Overview:: Overview of the Guile API.
-* Discouraged and Deprecated:: Obsolete back-compatible APIs.
+* Deprecation:: Obsolete back-compatible APIs.
* The SCM Type:: The fundamental data type for C code.
* Initialization:: Initializing Guile.
* Snarfing Macros:: Macros for snarfing initialization actions.
@@ -316,7 +316,7 @@ available through both Scheme and C interfaces.
@end menu
@include api-overview.texi
address@hidden api-discdepr.texi
address@hidden api-deprecated.texi
@include api-scm.texi
@include api-init.texi
@include api-snarf.texi
@@ -352,7 +352,6 @@ available through both Scheme and C interfaces.
* SRFI Support:: Support for various SRFIs.
* R6RS Support:: Modules defined by the R6RS.
* Readline Support:: Module for using the readline library.
-* Value History:: Maintaining a value history in the REPL.
* Pretty Printing:: Nicely formatting Scheme objects for output.
* Formatted Output:: The @code{format} procedure.
* File Tree Walk:: Traversing the file system.
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index e552159..4bdec27 100644
--- a/doc/ref/r6rs.texi
+++ b/doc/ref/r6rs.texi
@@ -37,9 +37,63 @@ is because the expansion of @code{library} sets the current
module, but
does not restore it. This is a bug.
@item
+R6RS unicode escapes within strings are disabled by default, because
+they conflict with Guile's already-existing escapes. R6RS behavior can
+be turned on via a reader option. @xref{String Syntax}, for more
+information.
+
address@hidden
A @code{set!} to a variable transformer may only expand to an
expression, not a definition---even if the original @code{set!}
expression was in definition context.
+
address@hidden
+Instead of using the algorithm detailed in chapter 10 of the R6RS,
+expansion of toplevel forms happens sequentially.
+
+For example, while the expansion of the following set of recursive
+nested definitions does do the correct thing:
+
address@hidden
+(let ()
+ (define even?
+ (lambda (x)
+ (or (= x 0) (odd? (- x 1)))))
+ (define-syntax odd?
+ (syntax-rules ()
+ ((odd? x) (not (even? x)))))
+ (even? 10))
address@hidden #t
address@hidden example
+
address@hidden
+The same definitions at the toplevel do not:
+
address@hidden
+(begin
+ (define even?
+ (lambda (x)
+ (or (= x 0) (odd? (- x 1)))))
+ (define-syntax odd?
+ (syntax-rules ()
+ ((odd? x) (not (even? x)))))
+ (even? 10))
+<unnamed port>:4:18: In procedure even?:
+<unnamed port>:4:18: Wrong type to apply: #<syntax-transformer odd?>
address@hidden example
+
+This is because when expanding the right-hand-side of @code{even?}, the
+reference to @code{odd?} is not yet marked as a syntax transformer, so
+it is assumed to be a function.
+
+While it is likely that we can fix the case of toplevel forms nested in
+a @code{begin} or a @code{library} form, a fix for toplevel programs
+seems trickier to implement in a backward-compatible way. Suggestions
+and/or patches would be appreciated.
+
address@hidden
+The @code{(rnrs io ports)} module is mostly unimplemented. Work is
+ongoing to fix this.
@end itemize
@node R6RS Standard Libraries
@@ -233,6 +287,7 @@ grouped below by the existing manual sections to which they
correspond.
@deffn {Scheme Syntax} let bindings body
@deffnx {Scheme Syntax} let* bindings body
@deffnx {Scheme Syntax} letrec bindings body
address@hidden {Scheme Syntax} letrec* bindings body
@xref{Local Bindings}, for documentation.
@end deffn
diff --git a/doc/ref/repl-modules.texi b/doc/ref/repl-modules.texi
index 385ba49..21f6520 100644
--- a/doc/ref/repl-modules.texi
+++ b/doc/ref/repl-modules.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -254,38 +254,6 @@ possibilities in @var{string-list}. Matching is
case-sensitive.
@end defun
address@hidden Value History
address@hidden Value History
-
address@hidden FIXME::martin: Review me!
-
address@hidden value history
-Another module which makes command line usage more convenient is
address@hidden(ice-9 history)}. This module will change the REPL so that each
-value which is evaluated and printed will be remembered under a name
-constructed from the dollar character (@code{$}) and the number of the
-evaluated expression.
-
-Consider an example session.
-
address@hidden
-guile> (use-modules (ice-9 history))
-guile> 1
-$1 = 1
-guile> (+ $1 $1)
-$2 = 2
-guile> (* $2 $2)
-$3 = 4
address@hidden example
-
-After loading the value history module @code{(ice-9 history)}, one
-(trivial) expression is evaluated. The result is stored into the
-variable @code{$1}. This fact is indicated by the output @code{$1 = },
-which is also caused by @code{(ice-9 history)}. In the next line, this
-variable is used two times, to produce the value @code{$2}, which in
-turn is used in the calculation for @code{$3}.
-
-
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index cf4e230..e07b148 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -36,7 +36,7 @@ support for languages other than Scheme.
@menu
* Readline::
-* Value Historyx::
+* Value History::
* REPL Commands::
* Error Handling::
* Interactive Debugging::
@@ -63,7 +63,7 @@ starts up interactively, so anything in this file has the
same effect
as if you type it in by hand at the ``scheme@@(guile-user)>'' prompt.
address@hidden Value Historyx
address@hidden Value History
@subsection Value History
Just as Readline helps you to reuse a previous input line, @dfn{value
diff --git a/libguile.h b/libguile.h
index 6f1b3f8..5e8c792 100644
--- a/libguile.h
+++ b/libguile.h
@@ -123,7 +123,6 @@ extern "C" {
#include "libguile/threads.h"
#include "libguile/inline.h"
-#include "libguile/discouraged.h"
#include "libguile/deprecated.h"
#ifdef __cplusplus
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 0ec0202..3045075 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -128,7 +128,6 @@ address@hidden@_la_SOURCES =
\
debug.c \
deprecated.c \
deprecation.c \
- discouraged.c \
dynwind.c \
eq.c \
error.c \
@@ -230,7 +229,6 @@ DOT_X_FILES = \
debug.x \
deprecated.x \
deprecation.x \
- discouraged.x \
dynl.x \
dynwind.x \
eq.x \
@@ -330,7 +328,6 @@ DOT_DOC_FILES = \
debug.doc \
deprecated.doc \
deprecation.doc \
- discouraged.doc \
dynl.doc \
dynwind.doc \
eq.doc \
@@ -490,7 +487,6 @@ modinclude_HEADERS = \
debug.h \
deprecated.h \
deprecation.h \
- discouraged.h \
dynl.h \
dynwind.h \
eq.h \
@@ -593,10 +589,11 @@ bin_SCRIPTS = guile-snarf
# We can re-enable install for some of these if/when they are documented
# and people feel like maintaining them. For now, this is not the case.
-noinst_SCRIPTS = guile-snarf-docs guile-func-name-check
+noinst_SCRIPTS = guile-snarf-docs
EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \
+ guile-func-name-check \
cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \
c-tokenize.lex version.h.in
\
scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map
@@ -619,7 +616,8 @@ libpath.h: $(srcdir)/Makefile.in
$(top_builddir)/config.status
@echo '/* generated by Makefile */' > libpath.tmp
@echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.tmp
@echo '#define SCM_LIBRARY_DIR
"$(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)"'>>libpath.tmp
- @echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.tmp
+ @echo '#define SCM_SITE_DIR
"$(pkgdatadir)/site/$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp
+ @echo '#define SCM_GLOBAL_SITE_DIR "$(pkgdatadir)/site"' >> libpath.tmp
@echo '#define SCM_LIB_DIR "$(libdir)"' >> libpath.tmp
@echo '#define SCM_EXTENSIONS_DIR
"$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions"' >> libpath.tmp
@echo '#define SCM_CCACHE_DIR
"$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp
@@ -645,7 +643,7 @@ libpath.h: $(srcdir)/Makefile.in
$(top_builddir)/config.status
@echo ' { "pkglibdir", "$(pkglibdir)" }, \' >> libpath.tmp
@echo ' { "pkgincludedir", "$(pkgincludedir)" }, \' \
>> libpath.tmp
- @echo ' { "extensionsdir",
"$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions" }, \' >> libpath.tmp
+ @echo ' { "extensiondir",
"$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions" }, \' >> libpath.tmp
@echo ' { "guileversion", "@GUILE_VERSION@" }, \' >> libpath.tmp
@echo ' { "libguileinterface", "@LIBGUILE_INTERFACE@" }, \' \
>> libpath.tmp
@@ -669,7 +667,7 @@ AM_V_FILTER_0 = @echo " FILTER" $@;
.c.doc:
-$(AM_V_FILTER)$(AWK) -f $(srcdir)/guile-func-name-check $< &&
(./guile-snarf-docs $(snarfcppopts) $< | ./guile_filter_doc_snarfage$(EXEEXT)
--filter-snarfage) > $@ || { rm $@; false; }
-$(DOT_X_FILES) $(EXTRA_DOT_X_FILES): scmconfig.h snarf.h guile-snarf.in
+$(DOT_X_FILES) $(EXTRA_DOT_X_FILES): scmconfig.h snarf.h guile-snarf.in
version.h
$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): scmconfig.h snarf.h
guile-snarf-docs.in guile_filter_doc_snarfage$(EXEEXT)
diff --git a/libguile/__scm.h b/libguile/__scm.h
index f0373e8..12d1e8a 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -390,11 +390,9 @@
#define SCM_T_INT32_MIN SCM_I_TYPE_MIN(scm_t_int32,SCM_T_UINT32_MAX)
#define SCM_T_INT32_MAX SCM_I_TYPE_MAX(scm_t_int32,SCM_T_UINT32_MAX)
-#if SCM_HAVE_T_INT64
#define SCM_T_UINT64_MAX SCM_I_UTYPE_MAX(scm_t_uint64)
#define SCM_T_INT64_MIN SCM_I_TYPE_MIN(scm_t_int64,SCM_T_UINT64_MAX)
#define SCM_T_INT64_MAX SCM_I_TYPE_MAX(scm_t_int64,SCM_T_UINT64_MAX)
-#endif
#if SCM_SIZEOF_LONG_LONG
#define SCM_I_ULLONG_MAX SCM_I_UTYPE_MAX(unsigned long long)
diff --git a/libguile/boolean.h b/libguile/boolean.h
index 7084fdf..8f55f1e 100644
--- a/libguile/boolean.h
+++ b/libguile/boolean.h
@@ -56,8 +56,7 @@
(SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_BOOL_F))
#define scm_is_true_and_not_nil(x) (!scm_is_false_or_nil (x))
-/*
-#nil is false. */
+/* #nil is false. */
#define scm_is_false(x) (scm_is_false_or_nil (x))
#define scm_is_true(x) (!scm_is_false (x))
@@ -91,6 +90,17 @@ SCM_API int scm_to_bool (SCM x);
+/* Older spellings for the above routines, kept around for
+ compatibility. */
+#define SCM_FALSEP(x) (scm_is_false (x))
+#define SCM_NFALSEP(x) (scm_is_true (x))
+#define SCM_BOOLP(x) (scm_is_bool (x))
+#define SCM_BOOL(x) (scm_from_bool (x))
+#define SCM_NEGATE_BOOL(f) (scm_from_bool (!(f)))
+#define SCM_BOOL_NOT(x) (scm_not (x))
+
+
+
/*
* The following macros efficiently implement boolean truth testing as
* expected by most lisps, which treat '() aka SCM_EOL as false.
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index a35e21a..648efe9 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -34,7 +34,6 @@
#include "libguile/bytevectors.h"
#include "libguile/bitvectors.h"
#include "libguile/deprecated.h"
-#include "libguile/discouraged.h"
#include "libguile/deprecation.h"
#include "libguile/snarf.h"
#include "libguile/validate.h"
@@ -1900,9 +1899,9 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call",
3, 0, 0,
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
+ SCM_VALIDATE_POINTER (SCM_ARG1, func);
- fptr = SCM_FOREIGN_POINTER (func, void);
+ fptr = SCM_POINTER_VALUE (func);
argv = scm_i_allocate_string_pointers (args);
for (argc = 0; argv[argc]; argc++)
@@ -1986,6 +1985,382 @@ scm_internal_stack_catch (SCM tag,
+SCM
+scm_short2num (short x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_short2num' is deprecated. Use scm_from_short instead.");
+ return scm_from_short (x);
+}
+
+SCM
+scm_ushort2num (unsigned short x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_ushort2num' is deprecated. Use scm_from_ushort instead.");
+ return scm_from_ushort (x);
+}
+
+SCM
+scm_int2num (int x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_int2num' is deprecated. Use scm_from_int instead.");
+ return scm_from_int (x);
+}
+
+SCM
+scm_uint2num (unsigned int x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_uint2num' is deprecated. Use scm_from_uint instead.");
+ return scm_from_uint (x);
+}
+
+SCM
+scm_long2num (long x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_long2num' is deprecated. Use scm_from_long instead.");
+ return scm_from_long (x);
+}
+
+SCM
+scm_ulong2num (unsigned long x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_ulong2num' is deprecated. Use scm_from_ulong instead.");
+ return scm_from_ulong (x);
+}
+
+SCM
+scm_size2num (size_t x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_size2num' is deprecated. Use scm_from_size_t instead.");
+ return scm_from_size_t (x);
+}
+
+SCM
+scm_ptrdiff2num (ptrdiff_t x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_ptrdiff2num' is deprecated. Use scm_from_ssize_t instead.");
+ return scm_from_ssize_t (x);
+}
+
+short
+scm_num2short (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2short' is deprecated. Use scm_to_short instead.");
+ return scm_to_short (x);
+}
+
+unsigned short
+scm_num2ushort (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2ushort' is deprecated. Use scm_to_ushort instead.");
+ return scm_to_ushort (x);
+}
+
+int
+scm_num2int (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2int' is deprecated. Use scm_to_int instead.");
+ return scm_to_int (x);
+}
+
+unsigned int
+scm_num2uint (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2uint' is deprecated. Use scm_to_uint instead.");
+ return scm_to_uint (x);
+}
+
+long
+scm_num2long (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2long' is deprecated. Use scm_to_long instead.");
+ return scm_to_long (x);
+}
+
+unsigned long
+scm_num2ulong (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2ulong' is deprecated. Use scm_to_ulong instead.");
+ return scm_to_ulong (x);
+}
+
+size_t
+scm_num2size (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2size' is deprecated. Use scm_to_size_t instead.");
+ return scm_to_size_t (x);
+}
+
+ptrdiff_t
+scm_num2ptrdiff (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2ptrdiff' is deprecated. Use scm_to_ssize_t instead.");
+ return scm_to_ssize_t (x);
+}
+
+#if SCM_SIZEOF_LONG_LONG != 0
+
+SCM
+scm_long_long2num (long long x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_long_long2num' is deprecated. Use scm_from_long_long instead.");
+ return scm_from_long_long (x);
+}
+
+SCM
+scm_ulong_long2num (unsigned long long x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_ulong_long2num' is deprecated. Use scm_from_ulong_long instead.");
+ return scm_from_ulong_long (x);
+}
+
+long long
+scm_num2long_long (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2long_long' is deprecated. Use scm_to_long_long instead.");
+ return scm_to_long_long (x);
+}
+
+unsigned long long
+scm_num2ulong_long (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2ulong_long' is deprecated. Use scm_from_ulong_long instead.");
+ return scm_to_ulong_long (x);
+}
+
+#endif
+
+SCM
+scm_make_real (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_real' is deprecated. Use scm_from_double instead.");
+ return scm_from_double (x);
+}
+
+double
+scm_num2dbl (SCM a, const char *why)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2dbl' is deprecated. Use scm_to_double instead.");
+ return scm_to_double (a);
+}
+
+SCM
+scm_float2num (float n)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_float2num' is deprecated. Use scm_from_double instead.");
+ return scm_from_double ((double) n);
+}
+
+SCM
+scm_double2num (double n)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_double2num' is deprecated. Use scm_from_double instead.");
+ return scm_from_double (n);
+}
+
+SCM
+scm_make_complex (double x, double y)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_complex' is deprecated. Use scm_c_make_rectangular instead.");
+ return scm_c_make_rectangular (x, y);
+}
+
+SCM
+scm_mem2symbol (const char *mem, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_mem2symbol' is deprecated. Use scm_from_locale_symboln instead.");
+ return scm_from_locale_symboln (mem, len);
+}
+
+SCM
+scm_mem2uninterned_symbol (const char *mem, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_mem2uninterned_symbol' is deprecated. "
+ "Use scm_make_symbol and scm_from_locale_symboln instead.");
+ return scm_make_symbol (scm_from_locale_stringn (mem, len));
+}
+
+SCM
+scm_str2symbol (const char *str)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_str2symbol' is deprecated. Use scm_from_locale_symbol instead.");
+ return scm_from_locale_symbol (str);
+}
+
+
+/* This function must only be applied to memory obtained via malloc,
+ since the GC is going to apply `free' to it when the string is
+ dropped.
+
+ Also, s[len] must be `\0', since we promise that strings are
+ null-terminated. Perhaps we could handle non-null-terminated
+ strings by claiming they're shared substrings of a string we just
+ made up. */
+SCM
+scm_take_str (char *s, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_take_str' is deprecated. Use scm_take_locale_stringn instead.");
+ return scm_take_locale_stringn (s, len);
+}
+
+/* `s' must be a malloc'd string. See scm_take_str. */
+SCM
+scm_take0str (char *s)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_take0str' is deprecated. Use scm_take_locale_string instead.");
+ return scm_take_locale_string (s);
+}
+
+SCM
+scm_mem2string (const char *src, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_mem2string' is deprecated. Use scm_from_locale_stringn instead.");
+ return scm_from_locale_stringn (src, len);
+}
+
+SCM
+scm_str2string (const char *src)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_str2string' is deprecated. Use scm_from_locale_string instead.");
+ return scm_from_locale_string (src);
+}
+
+SCM
+scm_makfrom0str (const char *src)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_makfrom0str' is deprecated."
+ "Use scm_from_locale_string instead, but check for NULL first.");
+ if (!src) return SCM_BOOL_F;
+ return scm_from_locale_string (src);
+}
+
+SCM
+scm_makfrom0str_opt (const char *src)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_makfrom0str_opt' is deprecated."
+ "Use scm_from_locale_string instead, but check for NULL first.");
+ return scm_makfrom0str (src);
+}
+
+
+SCM
+scm_allocate_string (size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead.");
+ return scm_i_make_string (len, NULL);
+}
+
+SCM_DEFINE (scm_make_keyword_from_dash_symbol,
"make-keyword-from-dash-symbol", 1, 0, 0,
+ (SCM symbol),
+ "Make a keyword object from a @var{symbol} that starts with a
dash.")
+#define FUNC_NAME s_scm_make_keyword_from_dash_symbol
+{
+ SCM dash_string, non_dash_symbol;
+
+ scm_c_issue_deprecation_warning
+ ("`scm_make_keyword_from_dash_symbol' is deprecated. Don't use dash
symbols.");
+
+ SCM_ASSERT (scm_is_symbol (symbol)
+ && (scm_i_symbol_ref (symbol, 0) == '-'),
+ symbol, SCM_ARG1, FUNC_NAME);
+
+ dash_string = scm_symbol_to_string (symbol);
+ non_dash_symbol =
+ scm_string_to_symbol (scm_c_substring (dash_string,
+ 1,
+ scm_c_string_length (dash_string)));
+
+ return scm_symbol_to_keyword (non_dash_symbol);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
+ (SCM keyword),
+ "Return the dash symbol for @var{keyword}.\n"
+ "This is the inverse of @code{make-keyword-from-dash-symbol}.")
+#define FUNC_NAME s_scm_keyword_dash_symbol
+{
+ SCM symbol = scm_keyword_to_symbol (keyword);
+ SCM parts = scm_list_2 (scm_from_locale_string ("-"),
+ scm_symbol_to_string (symbol));
+ scm_c_issue_deprecation_warning
+ ("`scm_keyword_dash_symbol' is deprecated. Don't use dash symbols.");
+
+ return scm_string_to_symbol (scm_string_append (parts));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_keyword (const char *s)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_c_make_keyword' is deprecated. Use scm_from_locale_keyword
instead.");
+ return scm_from_locale_keyword (s);
+}
+
+unsigned int
+scm_thread_sleep (unsigned int t)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_thread_sleep' is deprecated. Use scm_std_sleep instead.");
+ return scm_std_sleep (t);
+}
+
+unsigned long
+scm_thread_usleep (unsigned long t)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_thread_usleep' is deprecated. Use scm_std_usleep instead.");
+ return scm_std_usleep (t);
+}
+
+int scm_internal_select (int fds,
+ SELECT_TYPE *rfds,
+ SELECT_TYPE *wfds,
+ SELECT_TYPE *efds,
+ struct timeval *timeout)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_select' is deprecated. Use scm_std_select instead.");
+ return scm_std_select (fds, rfds, wfds, efds, timeout);
+}
+
+
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 65eda5b..893523f 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -27,6 +27,7 @@
#include "libguile/strings.h"
#include "libguile/eval.h"
#include "libguile/throw.h"
+#include "libguile/iselect.h"
#if (SCM_ENABLE_DEPRECATED == 1)
@@ -640,6 +641,102 @@ SCM_DEPRECATED SCM scm_internal_stack_catch (SCM tag,
+/* These functions were "discouraged" in 1.8, and now are deprecated. */
+
+/* scm_to_int, scm_from_int are the official functions to do the job,
+ but there is nothing wrong with using scm_num2int, etc.
+
+ These could be trivially defined via macros, but we leave them as
+ functions since existing code may take their addresses.
+*/
+
+SCM_DEPRECATED SCM scm_short2num (short n);
+SCM_DEPRECATED SCM scm_ushort2num (unsigned short n);
+SCM_DEPRECATED SCM scm_int2num (int n);
+SCM_DEPRECATED SCM scm_uint2num (unsigned int n);
+SCM_DEPRECATED SCM scm_long2num (long n);
+SCM_DEPRECATED SCM scm_ulong2num (unsigned long n);
+SCM_DEPRECATED SCM scm_size2num (size_t n);
+SCM_DEPRECATED SCM scm_ptrdiff2num (scm_t_ptrdiff n);
+SCM_DEPRECATED short scm_num2short (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED unsigned short scm_num2ushort (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED int scm_num2int (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED unsigned int scm_num2uint (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED long scm_num2long (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED unsigned long scm_num2ulong (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED scm_t_ptrdiff scm_num2ptrdiff (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED size_t scm_num2size (SCM num, unsigned long int pos,
+ const char *s_caller);
+#if SCM_SIZEOF_LONG_LONG != 0
+SCM_DEPRECATED SCM scm_long_long2num (long long sl);
+SCM_DEPRECATED SCM scm_ulong_long2num (unsigned long long sl);
+SCM_DEPRECATED long long scm_num2long_long (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED unsigned long long scm_num2ulong_long (SCM num, unsigned long
int pos,
+ const char *s_caller);
+#endif
+
+SCM_DEPRECATED SCM scm_make_real (double x);
+SCM_DEPRECATED double scm_num2dbl (SCM a, const char * why);
+SCM_DEPRECATED SCM scm_float2num (float n);
+SCM_DEPRECATED SCM scm_double2num (double n);
+
+/* The next two are implemented in numbers.c since they use features
+ only available there.
+*/
+SCM_DEPRECATED float scm_num2float (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_DEPRECATED double scm_num2double (SCM num, unsigned long int pos,
+ const char *s_caller);
+
+SCM_DEPRECATED SCM scm_make_complex (double x, double y);
+
+/* Discouraged because they don't make the encoding explicit.
+ */
+
+SCM_DEPRECATED SCM scm_mem2symbol (const char *mem, size_t len);
+SCM_DEPRECATED SCM scm_mem2uninterned_symbol (const char *mem, size_t len);
+SCM_DEPRECATED SCM scm_str2symbol (const char *str);
+
+SCM_DEPRECATED SCM scm_take_str (char *s, size_t len);
+SCM_DEPRECATED SCM scm_take0str (char *s);
+SCM_DEPRECATED SCM scm_mem2string (const char *src, size_t len);
+SCM_DEPRECATED SCM scm_str2string (const char *src);
+SCM_DEPRECATED SCM scm_makfrom0str (const char *src);
+SCM_DEPRECATED SCM scm_makfrom0str_opt (const char *src);
+
+/* Discouraged because scm_c_make_string has a better name and is more
+ consistent with make-string.
+ */
+SCM_DEPRECATED SCM scm_allocate_string (size_t len);
+
+/* Discouraged because they are just strange.
+ */
+
+SCM_DEPRECATED SCM scm_make_keyword_from_dash_symbol (SCM symbol);
+SCM_DEPRECATED SCM scm_keyword_dash_symbol (SCM keyword);
+
+/* Discouraged because it does not state what encoding S is in.
+ */
+
+SCM_DEPRECATED SCM scm_c_make_keyword (const char *s);
+
+SCM_DEPRECATED unsigned int scm_thread_sleep (unsigned int);
+SCM_DEPRECATED unsigned long scm_thread_usleep (unsigned long);
+SCM_DEPRECATED int scm_internal_select (int fds,
+ SELECT_TYPE *rfds,
+ SELECT_TYPE *wfds,
+ SELECT_TYPE *efds,
+ struct timeval *timeout);
+
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/discouraged.c b/libguile/discouraged.c
deleted file mode 100644
index 2621428..0000000
--- a/libguile/discouraged.c
+++ /dev/null
@@ -1,307 +0,0 @@
-/* This file contains definitions for discouraged features. When you
- discourage something, move it here when that is feasible.
-*/
-
-/* Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <libguile.h>
-
-
-#if (SCM_ENABLE_DISCOURAGED == 1)
-
-SCM
-scm_short2num (short x)
-{
- return scm_from_short (x);
-}
-
-SCM
-scm_ushort2num (unsigned short x)
-{
- return scm_from_ushort (x);
-}
-
-SCM
-scm_int2num (int x)
-{
- return scm_from_int (x);
-}
-
-SCM
-scm_uint2num (unsigned int x)
-{
- return scm_from_uint (x);
-}
-
-SCM
-scm_long2num (long x)
-{
- return scm_from_long (x);
-}
-
-SCM
-scm_ulong2num (unsigned long x)
-{
- return scm_from_ulong (x);
-}
-
-SCM
-scm_size2num (size_t x)
-{
- return scm_from_size_t (x);
-}
-
-SCM
-scm_ptrdiff2num (ptrdiff_t x)
-{
- return scm_from_ssize_t (x);
-}
-
-short
-scm_num2short (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_short (x);
-}
-
-unsigned short
-scm_num2ushort (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_ushort (x);
-}
-
-int
-scm_num2int (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_int (x);
-}
-
-unsigned int
-scm_num2uint (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_uint (x);
-}
-
-long
-scm_num2long (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_long (x);
-}
-
-unsigned long
-scm_num2ulong (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_ulong (x);
-}
-
-size_t
-scm_num2size (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_size_t (x);
-}
-
-ptrdiff_t
-scm_num2ptrdiff (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_ssize_t (x);
-}
-
-#if SCM_SIZEOF_LONG_LONG != 0
-
-SCM
-scm_long_long2num (long long x)
-{
- return scm_from_long_long (x);
-}
-
-SCM
-scm_ulong_long2num (unsigned long long x)
-{
- return scm_from_ulong_long (x);
-}
-
-long long
-scm_num2long_long (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_long_long (x);
-}
-
-unsigned long long
-scm_num2ulong_long (SCM x, unsigned long pos, const char *s_caller)
-{
- return scm_to_ulong_long (x);
-}
-
-#endif
-
-SCM
-scm_make_real (double x)
-{
- return scm_from_double (x);
-}
-
-double
-scm_num2dbl (SCM a, const char *why)
-{
- return scm_to_double (a);
-}
-
-SCM
-scm_float2num (float n)
-{
- return scm_from_double ((double) n);
-}
-
-SCM
-scm_double2num (double n)
-{
- return scm_from_double (n);
-}
-
-SCM
-scm_make_complex (double x, double y)
-{
- return scm_c_make_rectangular (x, y);
-}
-
-SCM
-scm_mem2symbol (const char *mem, size_t len)
-{
- return scm_from_locale_symboln (mem, len);
-}
-
-SCM
-scm_mem2uninterned_symbol (const char *mem, size_t len)
-{
- return scm_make_symbol (scm_from_locale_stringn (mem, len));
-}
-
-SCM
-scm_str2symbol (const char *str)
-{
- return scm_from_locale_symbol (str);
-}
-
-
-/* This function must only be applied to memory obtained via malloc,
- since the GC is going to apply `free' to it when the string is
- dropped.
-
- Also, s[len] must be `\0', since we promise that strings are
- null-terminated. Perhaps we could handle non-null-terminated
- strings by claiming they're shared substrings of a string we just
- made up. */
-SCM
-scm_take_str (char *s, size_t len)
-{
- SCM answer = scm_from_locale_stringn (s, len);
- free (s);
- return answer;
-}
-
-/* `s' must be a malloc'd string. See scm_take_str. */
-SCM
-scm_take0str (char *s)
-{
- return scm_take_locale_string (s);
-}
-
-SCM
-scm_mem2string (const char *src, size_t len)
-{
- return scm_from_locale_stringn (src, len);
-}
-
-SCM
-scm_str2string (const char *src)
-{
- return scm_from_locale_string (src);
-}
-
-SCM
-scm_makfrom0str (const char *src)
-{
- if (!src) return SCM_BOOL_F;
- return scm_from_locale_string (src);
-}
-
-SCM
-scm_makfrom0str_opt (const char *src)
-{
- return scm_makfrom0str (src);
-}
-
-
-SCM
-scm_allocate_string (size_t len)
-{
- return scm_i_make_string (len, NULL);
-}
-
-SCM_DEFINE (scm_make_keyword_from_dash_symbol,
"make-keyword-from-dash-symbol", 1, 0, 0,
- (SCM symbol),
- "Make a keyword object from a @var{symbol} that starts with a
dash.")
-#define FUNC_NAME s_scm_make_keyword_from_dash_symbol
-{
- SCM dash_string, non_dash_symbol;
-
- SCM_ASSERT (scm_is_symbol (symbol)
- && (scm_i_symbol_ref (symbol, 0) == '-'),
- symbol, SCM_ARG1, FUNC_NAME);
-
- dash_string = scm_symbol_to_string (symbol);
- non_dash_symbol =
- scm_string_to_symbol (scm_c_substring (dash_string,
- 1,
- scm_c_string_length (dash_string)));
-
- return scm_symbol_to_keyword (non_dash_symbol);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
- (SCM keyword),
- "Return the dash symbol for @var{keyword}.\n"
- "This is the inverse of @code{make-keyword-from-dash-symbol}.")
-#define FUNC_NAME s_scm_keyword_dash_symbol
-{
- SCM symbol = scm_keyword_to_symbol (keyword);
- SCM parts = scm_list_2 (scm_from_locale_string ("-"),
- scm_symbol_to_string (symbol));
- return scm_string_to_symbol (scm_string_append (parts));
-}
-#undef FUNC_NAME
-
-SCM
-scm_c_make_keyword (const char *s)
-{
- return scm_from_locale_keyword (s);
-}
-
-
-void
-scm_i_init_discouraged (void)
-{
-#include "libguile/discouraged.x"
-}
-
-#endif
diff --git a/libguile/discouraged.h b/libguile/discouraged.h
deleted file mode 100644
index dfa5811..0000000
--- a/libguile/discouraged.h
+++ /dev/null
@@ -1,184 +0,0 @@
-/* This file contains definitions for discouraged features. When you
- discourage something, move it here when that is feasible.
-
- A discouraged feature is one that shouldn't be used in new code
- since we have a better alternative now. However, there is nothing
- wrong with using the old feature, so it is OK to continue to use
- it.
-
- Eventually, discouraged features can be deprecated since removing
- them will make Guile simpler.
-*/
-
-#ifndef SCM_DISCOURAGED_H
-#define SCM_DISCOURAGED_H
-
-/* Copyright (C) 2004, 2006, 2010 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
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#include "libguile/__scm.h"
-
-#if SCM_ENABLE_DISCOURAGED == 1
-
-/* Discouraged because they do not follow the naming convention. That
- is, they end in "P" but return a C boolean. Also, SCM_BOOLP
- evaluates its argument twice.
-*/
-
-#define SCM_FALSEP scm_is_false
-#define SCM_NFALSEP scm_is_true
-#define SCM_BOOLP scm_is_bool
-#define SCM_EQ_P scm_is_eq
-
-
-/* Convert from a C boolean to a SCM boolean value */
-#define SCM_BOOL scm_from_bool
-
-/* Convert from a C boolean to a SCM boolean value and negate it */
-#define SCM_NEGATE_BOOL(f) scm_from_bool(!(f))
-
-/* SCM_BOOL_NOT returns the other boolean.
- * The order of ^s here is important for Borland C++ (!?!?!)
- */
-#define SCM_BOOL_NOT(x) (SCM_PACK (SCM_UNPACK (x) \
- ^ (SCM_UNPACK (SCM_BOOL_T) \
- ^ SCM_UNPACK (SCM_BOOL_F))))
-
-/* scm_to_int, scm_from_int are the official functions to do the job,
- but there is nothing wrong with using scm_num2int, etc.
-
- These could be trivially defined via macros, but we leave them as
- functions since existing code may take their addresses.
-*/
-
-SCM_API SCM scm_short2num (short n);
-SCM_API SCM scm_ushort2num (unsigned short n);
-SCM_API SCM scm_int2num (int n);
-SCM_API SCM scm_uint2num (unsigned int n);
-SCM_API SCM scm_long2num (long n);
-SCM_API SCM scm_ulong2num (unsigned long n);
-SCM_API SCM scm_size2num (size_t n);
-SCM_API SCM scm_ptrdiff2num (scm_t_ptrdiff n);
-SCM_API short scm_num2short (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API unsigned short scm_num2ushort (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API int scm_num2int (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API unsigned int scm_num2uint (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API long scm_num2long (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API unsigned long scm_num2ulong (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API scm_t_ptrdiff scm_num2ptrdiff (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API size_t scm_num2size (SCM num, unsigned long int pos,
- const char *s_caller);
-#if SCM_SIZEOF_LONG_LONG != 0
-SCM_API SCM scm_long_long2num (long long sl);
-SCM_API SCM scm_ulong_long2num (unsigned long long sl);
-SCM_API long long scm_num2long_long (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API unsigned long long scm_num2ulong_long (SCM num, unsigned long int pos,
- const char *s_caller);
-#endif
-
-SCM_API SCM scm_make_real (double x);
-SCM_API double scm_num2dbl (SCM a, const char * why);
-SCM_API SCM scm_float2num (float n);
-SCM_API SCM scm_double2num (double n);
-
-/* The next two are implemented in numbers.c since they use features
- only available there.
-*/
-SCM_API float scm_num2float (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_API double scm_num2double (SCM num, unsigned long int pos,
- const char *s_caller);
-
-SCM_API SCM scm_make_complex (double x, double y);
-
-/* Discouraged because they don't make the encoding explicit.
- */
-
-SCM_API SCM scm_mem2symbol (const char *mem, size_t len);
-SCM_API SCM scm_mem2uninterned_symbol (const char *mem, size_t len);
-SCM_API SCM scm_str2symbol (const char *str);
-
-SCM_API SCM scm_take_str (char *s, size_t len);
-SCM_API SCM scm_take0str (char *s);
-SCM_API SCM scm_mem2string (const char *src, size_t len);
-SCM_API SCM scm_str2string (const char *src);
-SCM_API SCM scm_makfrom0str (const char *src);
-SCM_API SCM scm_makfrom0str_opt (const char *src);
-
-/* Discouraged because scm_c_make_string has a better name and is more
- consistent with make-string.
- */
-SCM_API SCM scm_allocate_string (size_t len);
-
-/* Discouraged because scm_is_symbol has a better name,
- */
-#define SCM_SYMBOLP scm_is_symbol
-
-/* Discouraged because the alternatives have the better names.
- */
-#define SCM_SYMBOL_FUNC scm_symbol_fref
-#define SCM_SET_SYMBOL_FUNC scm_symbol_fset_x
-#define SCM_SYMBOL_PROPS scm_symbol_pref
-#define SCM_SET_SYMBOL_PROPS scm_symbol_pset_x
-
-/* Discouraged because there are better ways.
- */
-#define SCM_SYMBOL_HASH scm_i_symbol_hash
-#define SCM_SYMBOL_INTERNED_P(X) scm_i_symbol_is_interned
-
-/* Discouraged because they evaluated their arguments twice and/or
- don't fit the naming scheme.
-*/
-
-#define SCM_CONSP(x) (scm_is_pair (x))
-#define SCM_NCONSP(x) (!SCM_CONSP (x))
-#define SCM_NULLP(x) (scm_is_null (x))
-#define SCM_NNULLP(x) (!scm_is_null (x))
-
-/* Discouraged because they are just strange.
- */
-
-SCM_API SCM scm_make_keyword_from_dash_symbol (SCM symbol);
-SCM_API SCM scm_keyword_dash_symbol (SCM keyword);
-
-/* Discouraged because it does not state what encoding S is in.
- */
-
-SCM_API SCM scm_c_make_keyword (const char *s);
-
-/* Discouraged because the 'internal' and 'thread' moniker is
- confusing.
- */
-
-#define scm_internal_select scm_std_select
-#define scm_thread_sleep scm_std_sleep
-#define scm_thread_usleep scm_std_usleep
-
-SCM_INTERNAL void scm_i_init_discouraged (void);
-
-#endif /* SCM_ENABLE_DISCOURAGED == 1 */
-
-#endif /* SCM_DISCOURAGED_H */
diff --git a/libguile/dynl.c b/libguile/dynl.c
index b76e85c..dd1e0d3 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -235,18 +235,11 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
- (SCM name, SCM type, SCM dobj, SCM len),
- "Return a ``handle'' for the pointer @var{name} in the\n"
- "shared object referred to by @var{dobj}. The handle\n"
- "aliases a C value, and is declared to be of type\n"
- "@var{type}. Valid types are defined in the\n"
- "@code{(system foreign)} module.\n\n"
- "This facility works by asking the dynamic linker for\n"
- "the address of a symbol, then assuming that it aliases a\n"
- "value of a given type. Obviously, the user must be very\n"
- "careful to ensure that the value actually is of the\n"
- "declared type, or bad things will happen.\n\n"
+SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0,
+ (SCM name, SCM dobj),
+ "Return a ``wrapped pointer'' to the symbol @var{name}\n"
+ "in the shared object referred to by @var{dobj}. The returned\n"
+ "pointer points to a C object.\n\n"
"Regardless whether your C compiler prepends an underscore\n"
"@samp{_} to the global names in a program, you should\n"
"@strong{not} include this underscore in @var{name}\n"
@@ -254,11 +247,9 @@ SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1,
0,
#define FUNC_NAME s_scm_dynamic_pointer
{
void *val;
- scm_t_foreign_type t;
SCM_VALIDATE_STRING (1, name);
- t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
- SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
+ SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL)
SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
@@ -272,9 +263,7 @@ SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
scm_dynwind_end ();
- return scm_take_foreign_pointer (t, val,
- SCM_UNBNDP (len) ? 0 : scm_to_size_t
(len),
- NULL);
+ return scm_from_pointer (val, NULL);
}
}
#undef FUNC_NAME
@@ -292,10 +281,7 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
"since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func
{
- return scm_dynamic_pointer (name,
- scm_from_uint (SCM_FOREIGN_TYPE_VOID),
- dobj,
- SCM_UNDEFINED);
+ return scm_dynamic_pointer (name, dobj);
}
#undef FUNC_NAME
@@ -320,13 +306,13 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
"and its return value is ignored.")
#define FUNC_NAME s_scm_dynamic_call
{
- void (*fptr) ();
-
+ void (*fptr) (void);
+
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
+ SCM_VALIDATE_POINTER (SCM_ARG1, func);
- fptr = SCM_FOREIGN_POINTER (func, void);
+ fptr = SCM_POINTER_VALUE (func);
fptr ();
return SCM_UNSPECIFIED;
}
diff --git a/libguile/dynl.h b/libguile/dynl.h
index 3239d63..e735bcc 100644
--- a/libguile/dynl.h
+++ b/libguile/dynl.h
@@ -30,7 +30,7 @@
SCM_API SCM scm_dynamic_link (SCM fname);
SCM_API SCM scm_dynamic_unlink (SCM dobj);
SCM_API SCM scm_dynamic_object_p (SCM obj);
-SCM_API SCM scm_dynamic_pointer (SCM name, SCM type, SCM dobj, SCM len);
+SCM_API SCM scm_dynamic_pointer (SCM name, SCM dobj);
SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);
diff --git a/libguile/eq.h b/libguile/eq.h
index 1aeb1c4..c09d667 100644
--- a/libguile/eq.h
+++ b/libguile/eq.h
@@ -3,7 +3,7 @@
#ifndef SCM_EQ_H
#define SCM_EQ_H
-/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000, 2006, 2008, 2010 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,6 +27,13 @@
+/* scm_is_eq is defined in tags.h for some reason. */
+
+/* An older spelling for scm_is_eq. */
+#define SCM_EQ_P(x,y) (scm_is_eq (x, y))
+
+
+
SCM_API SCM scm_eq_p (SCM x, SCM y);
SCM_API SCM scm_eqv_p (SCM x, SCM y);
SCM_API SCM scm_equal_p (SCM x, SCM y);
diff --git a/libguile/evalext.c b/libguile/evalext.c
index b397cbd..ff2ff0e 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -77,7 +77,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0,
0,
{
case scm_tc7_vector:
case scm_tc7_wvect:
- case scm_tc7_foreign:
+ case scm_tc7_pointer:
case scm_tc7_hashtable:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
diff --git a/libguile/foreign.c b/libguile/foreign.c
index aae4c67..90607e8 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -1,5 +1,5 @@
/* Copyright (C) 2010 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
* as published by the Free Software Foundation; either version 3 of
@@ -59,6 +59,17 @@ SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
/* The cell representing the null pointer. */
static SCM null_pointer;
+#if SIZEOF_VOID_P == 4
+# define scm_to_uintptr scm_to_uint32
+# define scm_from_uintptr scm_from_uint32
+#elif SIZEOF_VOID_P == 8
+# define scm_to_uintptr scm_to_uint64
+# define scm_from_uintptr scm_from_uint64
+#else
+# error unsupported pointer size
+#endif
+
+
/* Raise a null pointer dereference error. */
static void
null_pointer_error (const char *func_name)
@@ -71,184 +82,120 @@ null_pointer_error (const char *func_name)
static SCM cif_to_procedure (SCM cif, SCM func_ptr);
-static SCM foreign_weak_refs = SCM_BOOL_F;
+static SCM pointer_weak_refs = SCM_BOOL_F;
static void
register_weak_reference (SCM from, SCM to)
{
- scm_hashq_set_x (foreign_weak_refs, from, to);
+ scm_hashq_set_x (pointer_weak_refs, from, to);
}
-
+
static void
-foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
+pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{
- scm_t_foreign_finalizer finalizer = data;
- finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
+ scm_t_pointer_finalizer finalizer = data;
+ finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
}
-SCM
-scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
- scm_t_foreign_finalizer finalizer)
+SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
+ (SCM address, SCM finalizer),
+ "Return a foreign pointer object pointing to @var{address}. "
+ "If @var{finalizer} is passed, it should be a pointer to a "
+ "one-argument C function that will be called when the pointer "
+ "object becomes unreachable.")
+#define FUNC_NAME s_scm_make_pointer
{
- SCM ret;
- scm_t_bits word0;
-
- word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
- | (finalizer ? (1<<16) : 0) | (len<<17));
- if (SCM_UNLIKELY ((word0 >> 17) != len))
- scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
+ void *c_finalizer;
+ scm_t_uintptr c_address;
- ret = scm_cell (word0, (scm_t_bits) ptr);
- if (finalizer)
+ c_address = scm_to_uintptr (address);
+ if (SCM_UNBNDP (finalizer))
+ c_finalizer = NULL;
+ else
{
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
- foreign_finalizer_trampoline,
- finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
+ SCM_VALIDATE_POINTER (2, finalizer);
+ c_finalizer = SCM_POINTER_VALUE (finalizer);
}
- return ret;
+ return scm_from_pointer ((void *) c_address, c_finalizer);
}
+#undef FUNC_NAME
-SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
- (SCM foreign),
- "Reference the foreign value pointed to by @var{foreign}.\n\n"
- "The value will be referenced according to its type.")
-#define FUNC_NAME s_scm_foreign_ref
+SCM
+scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer)
{
- scm_t_foreign_type ftype;
- scm_t_uint8 *ptr;
+ SCM ret;
- SCM_VALIDATE_FOREIGN (1, foreign);
- ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
- ftype = SCM_FOREIGN_TYPE (foreign);
-
- /* FIXME: is there a window in which we can see ptr but not foreign? */
- /* FIXME: accessing unaligned pointers */
- switch (ftype)
+ if (ptr == NULL && finalizer == NULL)
+ ret = null_pointer;
+ else
{
- case SCM_FOREIGN_TYPE_VOID:
- return scm_from_ulong ((unsigned long)ptr);
- case SCM_FOREIGN_TYPE_FLOAT:
- return scm_from_double (*(float*)ptr);
- case SCM_FOREIGN_TYPE_DOUBLE:
- return scm_from_double (*(double*)ptr);
- case SCM_FOREIGN_TYPE_UINT8:
- return scm_from_uint8 (*(scm_t_uint8*)ptr);
- case SCM_FOREIGN_TYPE_INT8:
- return scm_from_int8 (*(scm_t_int8*)ptr);
- case SCM_FOREIGN_TYPE_UINT16:
- return scm_from_uint16 (*(scm_t_uint16*)ptr);
- case SCM_FOREIGN_TYPE_INT16:
- return scm_from_int16 (*(scm_t_int16*)ptr);
- case SCM_FOREIGN_TYPE_UINT32:
- return scm_from_uint32 (*(scm_t_uint32*)ptr);
- case SCM_FOREIGN_TYPE_INT32:
- return scm_from_int32 (*(scm_t_int32*)ptr);
- case SCM_FOREIGN_TYPE_UINT64:
- return scm_from_uint64 (*(scm_t_uint64*)ptr);
- case SCM_FOREIGN_TYPE_INT64:
- return scm_from_int64 (*(scm_t_int64*)ptr);
- default:
- scm_wrong_type_arg_msg (FUNC_NAME, 1, foreign, "foreign");
+ scm_t_bits type;
+
+ type = scm_tc7_pointer | (finalizer ? (1 << 16UL) : 0UL);
+ ret = scm_cell (type, (scm_t_bits) ptr);
+
+ if (finalizer)
+ {
+ /* Register a finalizer for the newly created instance. */
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
+ pointer_finalizer_trampoline,
+ finalizer,
+ &prev_finalizer,
+ &prev_finalizer_data);
+ }
}
+
+ return ret;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
- (SCM foreign, SCM val),
- "Set the foreign value pointed to by @var{foreign}.\n\n"
- "The value will be set according to its type.")
-#define FUNC_NAME s_scm_foreign_set_x
+SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0,
+ (SCM pointer),
+ "Return the numerical value of @var{pointer}.")
+#define FUNC_NAME s_scm_pointer_address
{
- scm_t_foreign_type ftype;
- scm_t_uint8 *ptr;
-
- SCM_VALIDATE_FOREIGN (1, foreign);
-
- if (SCM_UNLIKELY (scm_is_eq (foreign, null_pointer)))
- /* Attempting to modify the pointer value of NULL_POINTER (which is
- read-only anyway), so raise an error. */
- null_pointer_error (FUNC_NAME);
+ SCM_VALIDATE_POINTER (1, pointer);
- ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
- ftype = SCM_FOREIGN_TYPE (foreign);
+ return scm_from_uintptr ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
+}
+#undef FUNC_NAME
- /* FIXME: is there a window in which we can see ptr but not foreign? */
- /* FIXME: unaligned access */
- switch (ftype)
- {
- case SCM_FOREIGN_TYPE_VOID:
- SCM_SET_CELL_WORD_1 (foreign, scm_to_ulong (val));
- break;
- case SCM_FOREIGN_TYPE_FLOAT:
- *(float*)ptr = scm_to_double (val);
- break;
- case SCM_FOREIGN_TYPE_DOUBLE:
- *(double*)ptr = scm_to_double (val);
- break;
- case SCM_FOREIGN_TYPE_UINT8:
- *(scm_t_uint8*)ptr = scm_to_uint8 (val);
- break;
- case SCM_FOREIGN_TYPE_INT8:
- *(scm_t_int8*)ptr = scm_to_int8 (val);
- break;
- case SCM_FOREIGN_TYPE_UINT16:
- *(scm_t_uint16*)ptr = scm_to_uint16 (val);
- break;
- case SCM_FOREIGN_TYPE_INT16:
- *(scm_t_int16*)ptr = scm_to_int16 (val);
- break;
- case SCM_FOREIGN_TYPE_UINT32:
- *(scm_t_uint32*)ptr = scm_to_uint32 (val);
- break;
- case SCM_FOREIGN_TYPE_INT32:
- *(scm_t_int32*)ptr = scm_to_int32 (val);
- break;
- case SCM_FOREIGN_TYPE_UINT64:
- *(scm_t_uint64*)ptr = scm_to_uint64 (val);
- break;
- case SCM_FOREIGN_TYPE_INT64:
- *(scm_t_int64*)ptr = scm_to_int64 (val);
- break;
- default:
- scm_wrong_type_arg_msg (FUNC_NAME, 1, val, "foreign");
- }
+SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0,
+ (SCM pointer),
+ "Assuming @var{pointer} points to a memory region that\n"
+ "holds a pointer, return this pointer.")
+#define FUNC_NAME s_scm_dereference_pointer
+{
+ SCM_VALIDATE_POINTER (1, pointer);
- return SCM_UNSPECIFIED;
+ return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer), NULL);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0,
- (SCM foreign, SCM uvec_type, SCM offset, SCM len),
- "Return a bytevector aliasing the memory pointed to by\n"
- "@var{foreign}.\n\n"
- "@var{foreign} must be a void pointer, a foreign whose type is\n"
- "@var{void}. By default, the resulting bytevector will alias\n"
- "all of the memory pointed to by @var{foreign}, from beginning\n"
- "to end, treated as a @code{vu8} array.\n\n"
+SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
+ (SCM pointer, SCM len, SCM offset, SCM uvec_type),
+ "Return a bytevector aliasing the @var{len} bytes pointed\n"
+ "to by @var{pointer}.\n\n"
"The user may specify an alternate default interpretation for\n"
"the memory by passing the @var{uvec_type} argument, to indicate\n"
"that the memory is an array of elements of that type.\n"
"@var{uvec_type} should be something that\n"
"@code{uniform-vector-element-type} would return, like
@code{f32}\n"
"or @code{s16}.\n\n"
- "Users may also specify that the bytevector should only alias a\n"
- "subset of the memory, by specifying @var{offset} and @var{len}\n"
- "arguments.")
-#define FUNC_NAME s_scm_foreign_to_bytevector
+ "When @var{offset} is passed, it specifies the offset in bytes\n"
+ "relative to @var{pointer} of the memory region aliased by the\n"
+ "returned bytevector.")
+#define FUNC_NAME s_scm_pointer_to_bytevector
{
SCM ret;
scm_t_int8 *ptr;
size_t boffset, blen;
scm_t_array_element_type btype;
- SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
- ptr = SCM_FOREIGN_POINTER (foreign, scm_t_int8);
+ SCM_VALIDATE_POINTER (1, pointer);
+ ptr = SCM_POINTER_VALUE (pointer);
if (SCM_UNLIKELY (ptr == NULL))
null_pointer_error (FUNC_NAME);
@@ -283,98 +230,67 @@ SCM_DEFINE (scm_foreign_to_bytevector,
"foreign->bytevector", 1, 3, 0,
"uniform vector type");
}
}
-
+
if (SCM_UNBNDP (offset))
boffset = 0;
- else if (SCM_FOREIGN_LEN (foreign))
- boffset = scm_to_unsigned_integer (offset, 0,
- SCM_FOREIGN_LEN (foreign) - 1);
else
boffset = scm_to_size_t (offset);
- if (SCM_UNBNDP (len))
- {
- if (SCM_FOREIGN_LEN (foreign))
- blen = SCM_FOREIGN_LEN (foreign) - boffset;
- else
- scm_misc_error (FUNC_NAME,
- "length needed to convert foreign pointer to
bytevector",
- SCM_EOL);
- }
- else
- {
- if (SCM_FOREIGN_LEN (foreign))
- blen = scm_to_unsigned_integer (len, 0,
- SCM_FOREIGN_LEN (foreign) - boffset);
- else
- blen = scm_to_size_t (len);
- }
+ blen = scm_to_size_t (len);
ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
- register_weak_reference (ret, foreign);
+ register_weak_reference (ret, pointer);
return ret;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_bytevector_to_foreign, "bytevector->foreign", 1, 2, 0,
- (SCM bv, SCM offset, SCM len),
- "Return a foreign pointer aliasing the memory pointed to by\n"
- "@var{bv}.\n\n"
- "The resulting foreign will be a void pointer, a foreign whose\n"
- "type is @code{void}. By default it will alias all of the\n"
- "memory pointed to by @var{bv}, from beginning to end.\n\n"
- "Users may explicily specify that the foreign should only alias
a\n"
- "subset of the memory, by specifying @var{offset} and @var{len}\n"
- "arguments.")
-#define FUNC_NAME s_scm_bytevector_to_foreign
+SCM_DEFINE (scm_bytevector_to_pointer, "bytevector->pointer", 1, 1, 0,
+ (SCM bv, SCM offset),
+ "Return a pointer pointer aliasing the memory pointed to by\n"
+ "@var{bv} or @var{offset} bytes after @var{bv} when @var{offset}\n"
+ "is passed.")
+#define FUNC_NAME s_scm_bytevector_to_pointer
{
SCM ret;
scm_t_int8 *ptr;
- size_t boffset, blen;
+ size_t boffset;
SCM_VALIDATE_BYTEVECTOR (1, bv);
ptr = SCM_BYTEVECTOR_CONTENTS (bv);
-
+
if (SCM_UNBNDP (offset))
boffset = 0;
else
boffset = scm_to_unsigned_integer (offset, 0,
SCM_BYTEVECTOR_LENGTH (bv) - 1);
- if (SCM_UNBNDP (len))
- blen = SCM_BYTEVECTOR_LENGTH (bv) - boffset;
- else
- blen = scm_to_unsigned_integer (len, 0,
- SCM_BYTEVECTOR_LENGTH (bv) - boffset);
-
- ret = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, ptr + boffset, blen,
- NULL);
+ ret = scm_from_pointer (ptr + boffset, NULL);
register_weak_reference (ret, bv);
return ret;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_foreign_set_finalizer_x, "foreign-set-finalizer!", 2, 0, 0,
- (SCM foreign, SCM finalizer),
+SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
+ (SCM pointer, SCM finalizer),
"Arrange for the C procedure wrapped by @var{finalizer} to be\n"
- "called on the pointer wrapped by @var{foreign} when
@var{foreign}\n"
+ "called on the pointer wrapped by @var{pointer} when
@var{pointer}\n"
"becomes unreachable. Note: the C procedure should not call into\n"
"Scheme. If you need a Scheme finalizer, use guardians.")
-#define FUNC_NAME s_scm_foreign_set_finalizer_x
+#define FUNC_NAME s_scm_set_pointer_finalizer_x
{
void *c_finalizer;
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
- SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
- SCM_VALIDATE_FOREIGN_TYPED (2, finalizer, VOID);
-
- c_finalizer = SCM_FOREIGN_POINTER (finalizer, void);
+ SCM_VALIDATE_POINTER (1, pointer);
+ SCM_VALIDATE_POINTER (2, finalizer);
+
+ c_finalizer = SCM_POINTER_VALUE (finalizer);
- SCM_SET_CELL_WORD_0 (foreign, SCM_CELL_WORD_0 (foreign) | (1<<16));
+ SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (foreign),
- foreign_finalizer_trampoline,
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
+ pointer_finalizer_trampoline,
c_finalizer,
&prev_finalizer,
&prev_finalizer_data);
@@ -386,48 +302,10 @@ SCM_DEFINE (scm_foreign_set_finalizer_x,
"foreign-set-finalizer!", 2, 0, 0,
void
-scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
+scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<foreign ", port);
- switch (SCM_FOREIGN_TYPE (foreign))
- {
- case SCM_FOREIGN_TYPE_FLOAT:
- scm_puts ("float ", port);
- break;
- case SCM_FOREIGN_TYPE_DOUBLE:
- scm_puts ("double ", port);
- break;
- case SCM_FOREIGN_TYPE_UINT8:
- scm_puts ("uint8 ", port);
- break;
- case SCM_FOREIGN_TYPE_INT8:
- scm_puts ("int8 ", port);
- break;
- case SCM_FOREIGN_TYPE_UINT16:
- scm_puts ("uint16 ", port);
- break;
- case SCM_FOREIGN_TYPE_INT16:
- scm_puts ("int16 ", port);
- break;
- case SCM_FOREIGN_TYPE_UINT32:
- scm_puts ("uint32 ", port);
- break;
- case SCM_FOREIGN_TYPE_INT32:
- scm_puts ("int32 ", port);
- break;
- case SCM_FOREIGN_TYPE_UINT64:
- scm_puts ("uint64 ", port);
- break;
- case SCM_FOREIGN_TYPE_INT64:
- scm_puts ("int64 ", port);
- break;
- case SCM_FOREIGN_TYPE_VOID:
- scm_puts ("pointer ", port);
- break;
- default:
- scm_wrong_type_arg_msg ("%print-foreign", 1, foreign, "foreign");
- }
- scm_display (scm_foreign_ref (foreign), port);
+ scm_puts ("#<pointer 0x", port);
+ scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
scm_putc ('>', port);
}
@@ -669,8 +547,9 @@ SCM_DEFINE (scm_make_foreign_function,
"make-foreign-function", 3, 0, 0,
ffi_cif *cif;
ffi_type **type_ptrs;
ffi_type *types;
-
- SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID);
+
+ SCM_VALIDATE_POINTER (2, func_ptr);
+
nargs = scm_ilength (arg_types);
SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
/* fixme: assert nargs < 1<<32 */
@@ -699,8 +578,7 @@ SCM_DEFINE (scm_make_foreign_function,
"make-foreign-function", 3, 0, 0,
+ (nargs + n_struct_elts + 1)*sizeof(ffi_type));
mem = scm_gc_malloc_pointerless (cif_len, "foreign");
- scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem,
- cif_len, NULL);
+ scm_cif = scm_from_pointer (mem, NULL);
cif = (ffi_cif *) mem;
/* reuse cif_len to walk through the mem */
@@ -852,9 +730,13 @@ static const SCM objcode_trampolines[10] = {
static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
{
- unsigned nargs = SCM_FOREIGN_POINTER (cif, ffi_cif)->nargs;
+ ffi_cif *c_cif;
+ unsigned int nargs;
SCM objcode, table, ret;
-
+
+ c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
+ nargs = c_cif->nargs;
+
if (nargs < 10)
objcode = objcode_trampolines[nargs];
else
@@ -906,17 +788,10 @@ unpack (const ffi_type *type, void *loc, SCM x)
*(scm_t_int64 *) loc = scm_to_int64 (x);
break;
case FFI_TYPE_STRUCT:
- if (!SCM_FOREIGN_TYPED_P (x, VOID))
- scm_wrong_type_arg_msg ("foreign-call", 0, x, "foreign void pointer");
- if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
- scm_wrong_type_arg_msg ("foreign-call", 0, x,
- "foreign void pointer of correct length");
- memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
+ memcpy (loc, SCM_POINTER_VALUE (x), type->size);
break;
case FFI_TYPE_POINTER:
- if (!SCM_FOREIGN_TYPED_P (x, VOID))
- scm_wrong_type_arg_msg ("foreign-call", 0, x, "foreign void pointer");
- *(void **) loc = SCM_FOREIGN_POINTER (x, void);
+ *(void **) loc = SCM_POINTER_VALUE (x);
break;
default:
abort ();
@@ -955,12 +830,10 @@ pack (const ffi_type * type, const void *loc)
{
void *mem = scm_gc_malloc_pointerless (type->size, "foreign");
memcpy (mem, loc, type->size);
- return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
- mem, type->size, NULL);
+ return scm_from_pointer (mem, NULL);
}
case FFI_TYPE_POINTER:
- return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
- *(void **) loc, 0, NULL);
+ return scm_from_pointer (*(void **) loc, NULL);
default:
abort ();
}
@@ -981,8 +854,8 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
size_t arg_size;
scm_t_ptrdiff off;
- cif = SCM_FOREIGN_POINTER (SCM_CAR (foreign), ffi_cif);
- func = SCM_FOREIGN_POINTER (SCM_CDR (foreign), void);
+ cif = SCM_POINTER_VALUE (SCM_CAR (foreign));
+ func = SCM_POINTER_VALUE (SCM_CDR (foreign));
/* Argument pointers. */
args = alloca (sizeof (void *) * cif->nargs);
@@ -1093,8 +966,7 @@ scm_init_foreign (void)
#endif
);
- null_pointer = scm_cell (scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8UL),
- 0);
+ null_pointer = scm_cell (scm_tc7_pointer, 0);
scm_define (sym_null, null_pointer);
}
@@ -1105,7 +977,7 @@ scm_register_foreign (void)
"scm_init_foreign",
(scm_t_extension_init_func)scm_init_foreign,
NULL);
- foreign_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
}
/*
diff --git a/libguile/foreign.h b/libguile/foreign.h
index a162d5d..cdd3b3c 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -21,25 +21,18 @@
#include "libguile/__scm.h"
-/* A foreign value is some value that exists outside of Guile. It is
represented
- by a cell whose second word is a pointer. The first word has the
- scm_tc7_foreign typecode and type of the aliased (pointed-to) value in its
- lower 16 bits.
-
- There are numeric types, like uint32 and float, and there is a "generic
- pointer" type, void. Void pointers also have a length associated with them,
- in the high bits of the first word of the SCM object, but since they really
- are pointers out into the wild wooly world of C, perhaps we don't actually
- know how much memory they take up. In that, most general case, the "len"
- will be stored as 0.
+/* A "foreign pointer" is a wrapped C pointer. It is represented by a
+ cell whose second word is a pointer. The first word has the
+ `scm_tc7_pointer' type code and a bit saying whether it has an
+ associated finalizer or not.
The basic idea is that we can help the programmer to avoid cutting herself,
- but we won't take away her knives.
-*/
-typedef enum
+ but we won't take away her knives. */
+
+enum scm_t_foreign_type
{
- SCM_FOREIGN_TYPE_VOID, /* a pointer out into the wilderness */
- SCM_FOREIGN_TYPE_FLOAT,
+ SCM_FOREIGN_TYPE_VOID,
+ SCM_FOREIGN_TYPE_FLOAT,
SCM_FOREIGN_TYPE_DOUBLE,
SCM_FOREIGN_TYPE_UINT8,
SCM_FOREIGN_TYPE_INT8,
@@ -50,56 +43,34 @@ typedef enum
SCM_FOREIGN_TYPE_UINT64,
SCM_FOREIGN_TYPE_INT64,
SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64
- } scm_t_foreign_type;
-
-
-typedef void (*scm_t_foreign_finalizer) (void *);
-
-#define SCM_FOREIGN_P(x) \
- (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_foreign)
-#define SCM_VALIDATE_FOREIGN(pos, x) \
- SCM_MAKE_VALIDATE (pos, x, FOREIGN_P)
-#define SCM_FOREIGN_TYPE(x) \
- ((scm_t_foreign_type)((SCM_CELL_WORD_0 (x) >> 8)&0xff))
-#define SCM_FOREIGN_POINTER(x, ctype) \
- ((ctype*)SCM_CELL_WORD_1 (x))
-#define SCM_FOREIGN_VALUE_REF(x, ctype) \
- (*SCM_FOREIGN_POINTER (x, ctype))
-#define SCM_FOREIGN_VALUE_SET(x, ctype, val) \
- (*SCM_FOREIGN_POINTER (x, ctype) = (val))
-#define SCM_FOREIGN_HAS_FINALIZER(x) \
+ };
+
+typedef enum scm_t_foreign_type scm_t_foreign_type;
+
+typedef void (*scm_t_pointer_finalizer) (void *);
+
+#define SCM_POINTER_P(x) \
+ (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_pointer)
+#define SCM_VALIDATE_POINTER(pos, x) \
+ SCM_MAKE_VALIDATE (pos, x, POINTER_P)
+#define SCM_POINTER_VALUE(x) \
+ ((void *) SCM_CELL_WORD_1 (x))
+#define SCM_POINTER_HAS_FINALIZER(x) \
((SCM_CELL_WORD_0 (x) >> 16) & 0x1)
-#define SCM_FOREIGN_LEN(x) \
- ((size_t)(SCM_CELL_WORD_0 (x) >> 17))
-
-#define SCM_FOREIGN_TYPED_P(x, type) \
- (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) == SCM_FOREIGN_TYPE_##type)
-#define SCM_VALIDATE_FOREIGN_TYPED(pos, x, type) \
- do { \
- SCM_ASSERT_TYPE (SCM_FOREIGN_TYPED_P (x, type), x, pos, FUNC_NAME, \
- "FOREIGN_"#type"_P"); \
- } while (0)
-
-#define SCM_FOREIGN_VALUE_P(x) \
- (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID)
-#define SCM_VALIDATE_FOREIGN_VALUE(pos, x) \
- SCM_MAKE_VALIDATE (pos, x, FOREIGN_VALUE_P)
-
-SCM_API SCM scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr,
- size_t len,
- scm_t_foreign_finalizer finalizer);
+
+SCM_API SCM scm_from_pointer (void *, scm_t_pointer_finalizer);
SCM_API SCM scm_alignof (SCM type);
SCM_API SCM scm_sizeof (SCM type);
-SCM_API SCM scm_foreign_type (SCM foreign);
-SCM_API SCM scm_foreign_ref (SCM foreign);
-SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val);
-SCM_API SCM scm_foreign_to_bytevector (SCM foreign, SCM type,
+SCM_API SCM scm_pointer_address (SCM pointer);
+SCM_API SCM scm_pointer_to_bytevector (SCM pointer, SCM type,
SCM offset, SCM len);
-SCM_API SCM scm_foreign_set_finalizer_x (SCM foreign, SCM finalizer);
-SCM_API SCM scm_bytevector_to_foreign (SCM bv, SCM offset, SCM len);
+SCM_API SCM scm_set_pointer_finalizer_x (SCM pointer, SCM finalizer);
+SCM_API SCM scm_bytevector_to_pointer (SCM bv, SCM offset);
-SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
+SCM_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer);
+SCM_INTERNAL SCM scm_dereference_pointer (SCM pointer);
+SCM_INTERNAL void scm_i_pointer_print (SCM pointer, SCM port,
scm_print_state *pstate);
diff --git a/libguile/gc.c b/libguile/gc.c
index 192dd52..91250ba 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -746,7 +746,7 @@ scm_i_tag_name (scm_t_bits tag)
return "cons (immediate car)";
case scm_tcs_cons_nimcar:
return "cons (non-immediate car)";
- case scm_tc7_foreign:
+ case scm_tc7_pointer:
return "foreign";
case scm_tc7_hashtable:
return "hashtable";
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index 851578f..73f847f 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -78,9 +78,7 @@
type.
- we now use SCM_SIZEOF_FOO != 0 rather than SCM_HAVE_FOO for any
- cases where the size might actually vary. For types where the
- size is fixed, we use SCM_HAVE_FOO, i.e. you can see us define or
- not define SCM_HAVE_T_INT64 below when appropriate.
+ cases where the size might actually vary.
Rationales (not finished):
@@ -220,12 +218,6 @@ main (int argc, char *argv[])
else
pf ("/* #undef GUILE_DEBUG */\n");
- /*** SCM_ENABLE_DISCOURAGED (0 or 1) ***/
- pf ("\n");
- pf ("/* Set to 1 if you want to enable discouraged features. */\n");
- pf ("/* (value will be 0 or 1). */\n");
- pf ("#define SCM_ENABLE_DISCOURAGED %d\n", SCM_I_GSC_ENABLE_DISCOURAGED);
-
/*** SCM_ENABLE_DEPRECATED (0 or 1) ***/
pf ("\n");
pf ("/* Set to 1 if you want to enable deprecated features. */\n");
@@ -290,28 +282,10 @@ main (int argc, char *argv[])
return 1;
pf ("\n");
- pf ("/* 64-bit integer -- if available SCM_HAVE_T_INT64 will be 1 and\n"
- " scm_t_int64 will be a suitable type, otherwise SCM_HAVE_T_INT64\n"
- " will be 0. */\n");
- if (SCM_I_GSC_T_INT64)
- {
- pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n");
- pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64);
- }
- else
- pf ("#define SCM_HAVE_T_INT64 0 /* 0 or 1 */\n");
-
- pf ("\n");
- pf ("/* 64-bit unsigned integer -- if available SCM_HAVE_T_UINT64 will\n"
- " be 1 and scm_t_uint64 will be a suitable type, otherwise\n"
- " SCM_HAVE_T_UINT64 will be 0. */\n");
- if (SCM_I_GSC_T_UINT64)
- {
- pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n");
- pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64);
- }
- else
- pf ("#define SCM_HAVE_T_UINT64 0 /* 0 or 1 */\n");
+ pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n");
+ pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64);
+ pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n");
+ pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64);
pf ("\n");
pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n"
diff --git a/libguile/goops.c b/libguile/goops.c
index 6fc073b..5e4b496 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -221,7 +221,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_class_vector;
- case scm_tc7_foreign:
+ case scm_tc7_pointer:
return class_foreign;
case scm_tc7_hashtable:
return class_hashtable;
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index de4bff6..ef3ad23 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -793,14 +793,11 @@ create_gsubr (int define, const char *name,
/* make objtable */
sname = scm_from_locale_symbol (name);
table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
- SCM_SIMPLE_VECTOR_SET (table, 0,
- scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
- fcn, 0, NULL));
+ SCM_SIMPLE_VECTOR_SET (table, 0, scm_from_pointer (fcn, NULL));
SCM_SIMPLE_VECTOR_SET (table, 1, sname);
if (generic_loc)
SCM_SIMPLE_VECTOR_SET (table, 2,
- scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
- generic_loc, 0, NULL));
+ scm_from_pointer (generic_loc, NULL));
/* make program */
ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index e94d0d0..faa4bb0 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -41,12 +41,19 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
#define SCM_GSUBR_MAX 10
#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
+
#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) &&
SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
-#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF
(SCM_PROGRAM_OBJTABLE (x), 0), void)))
+#define SCM_SUBRF(x) \
+ ((SCM (*) (void)) \
+ SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0)))
+
#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
-#define SCM_SUBR_GENERIC(x) \
- (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2),
SCM))
+
+#define SCM_SUBR_GENERIC(x) \
+ ((SCM *) \
+ SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2)))
+
#define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_SUBR_GENERIC (x) = (g))
diff --git a/libguile/init.c b/libguile/init.c
index 4843910..b511aae 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -134,7 +134,6 @@
#include "libguile/extensions.h"
#include "libguile/uniform.h"
#include "libguile/srfi-4.h"
-#include "libguile/discouraged.h"
#include "libguile/deprecated.h"
#include "libguile/init.h"
@@ -562,10 +561,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_goops ();
-#if SCM_ENABLE_DISCOURAGED == 1
- scm_i_init_discouraged ();
-#endif
-
#if SCM_ENABLE_DEPRECATED == 1
scm_i_init_deprecated ();
#endif
diff --git a/libguile/load.c b/libguile/load.c
index f0e5d73..7c06c9b 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -167,8 +167,9 @@ SCM_DEFINE (scm_sys_library_dir, "%library-dir", 0,0,0,
#ifdef SCM_SITE_DIR
SCM_DEFINE (scm_sys_site_dir, "%site-dir", 0,0,0,
(),
- "Return the directory where the Guile site files are installed.\n"
- "E.g., may return \"/usr/share/guile/site\".")
+ "Return the directory where users should install Scheme code for
use\n"
+ "with this version of Guile.\n\n"
+ "E.g., may return \"/usr/share/guile/site/" SCM_EFFECTIVE_VERSION
"\".")
#define FUNC_NAME s_scm_sys_site_dir
{
return scm_from_locale_string (SCM_SITE_DIR);
@@ -176,6 +177,18 @@ SCM_DEFINE (scm_sys_site_dir, "%site-dir", 0,0,0,
#undef FUNC_NAME
#endif /* SCM_SITE_DIR */
+#ifdef SCM_GLOBAL_SITE_DIR
+SCM_DEFINE (scm_sys_global_site_dir, "%global-site-dir", 0,0,0,
+ (),
+ "Return the directory where users should install Scheme code for
use\n"
+ "with all versions of Guile.\n\n"
+ "E.g., may return \"/usr/share/guile/site\".")
+#define FUNC_NAME s_scm_sys_global_site_dir
+{
+ return scm_from_locale_string (SCM_GLOBAL_SITE_DIR);
+}
+#undef FUNC_NAME
+#endif /* SCM_GLOBAL_SITE_DIR */
@@ -239,8 +252,9 @@ scm_init_load_path ()
else if (env)
path = scm_parse_path (scm_from_locale_string (env), path);
else
- path = scm_list_3 (scm_from_locale_string (SCM_LIBRARY_DIR),
+ path = scm_list_4 (scm_from_locale_string (SCM_LIBRARY_DIR),
scm_from_locale_string (SCM_SITE_DIR),
+ scm_from_locale_string (SCM_GLOBAL_SITE_DIR),
scm_from_locale_string (SCM_PKGDATA_DIR));
env = getenv ("GUILE_SYSTEM_COMPILED_PATH");
@@ -614,10 +628,10 @@ compiled_is_fresh (SCM full_filename, SCM
compiled_filename)
source = scm_to_locale_string (full_filename);
compiled = scm_to_locale_string (compiled_filename);
-
+
if (stat (source, &stat_source) == 0
&& stat (compiled, &stat_compiled) == 0
- && stat_source.st_mtime == stat_compiled.st_mtime)
+ && stat_source.st_mtime <= stat_compiled.st_mtime)
{
res = 1;
}
diff --git a/libguile/load.h b/libguile/load.h
index 0bff53c..d1afefb 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -3,7 +3,7 @@
#ifndef SCM_LOAD_H
#define SCM_LOAD_H
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010 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
@@ -32,6 +32,7 @@ SCM_API SCM scm_c_primitive_load (const char *filename);
SCM_API SCM scm_sys_package_data_dir (void);
SCM_API SCM scm_sys_library_dir (void);
SCM_API SCM scm_sys_site_dir (void);
+SCM_API SCM scm_sys_global_site_dir (void);
SCM_API SCM scm_search_path (SCM path, SCM filename, SCM rest);
SCM_API SCM scm_sys_search_load_path (SCM filename);
SCM_API SCM scm_primitive_load_path (SCM filename_and_exception_on_not_found);
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 509e1c1..6f04ea5 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -67,8 +67,6 @@
#include "libguile/eq.h"
-#include "libguile/discouraged.h"
-
/* values per glibc, if not already defined */
#ifndef M_LOG10E
#define M_LOG10E 0.43429448190325182765
@@ -6285,8 +6283,6 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max)
#define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
#include "libguile/conv-integer.i.c"
-#if SCM_HAVE_T_INT64
-
#define TYPE scm_t_int64
#define TYPE_MIN SCM_T_INT64_MIN
#define TYPE_MAX SCM_T_INT64_MAX
@@ -6303,8 +6299,6 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max)
#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
#include "libguile/conv-uinteger.i.c"
-#endif
-
void
scm_to_mpz (SCM val, mpz_t rop)
{
@@ -6357,11 +6351,14 @@ scm_from_double (double val)
return z;
}
-#if SCM_ENABLE_DISCOURAGED == 1
+#if SCM_ENABLE_DEPRECATED == 1
float
scm_num2float (SCM num, unsigned long int pos, const char *s_caller)
{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2float' is deprecated. Use scm_to_double instead.");
+
if (SCM_BIGP (num))
{
float res = mpz_get_d (SCM_I_BIG_MPZ (num));
@@ -6377,6 +6374,9 @@ scm_num2float (SCM num, unsigned long int pos, const char
*s_caller)
double
scm_num2double (SCM num, unsigned long int pos, const char *s_caller)
{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2double' is deprecated. Use scm_to_double instead.");
+
if (SCM_BIGP (num))
{
double res = mpz_get_d (SCM_I_BIG_MPZ (num));
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 95d59b8..abb08f0 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -3,7 +3,7 @@
#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008,
2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008,
2009, 2010 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
@@ -353,16 +353,12 @@ SCM_API SCM scm_from_uint32 (scm_t_uint32 x);
SCM_API scm_t_wchar scm_to_wchar (SCM x);
SCM_API SCM scm_from_wchar (scm_t_wchar x);
-#if SCM_HAVE_T_INT64
-
SCM_API scm_t_int64 scm_to_int64 (SCM x);
SCM_API SCM scm_from_int64 (scm_t_int64 x);
SCM_API scm_t_uint64 scm_to_uint64 (SCM x);
SCM_API SCM scm_from_uint64 (scm_t_uint64 x);
-#endif
-
SCM_API void scm_to_mpz (SCM x, mpz_t rop);
SCM_API SCM scm_from_mpz (mpz_t rop);
diff --git a/libguile/pairs.h b/libguile/pairs.h
index 0e98162..6edfc9c 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -56,11 +56,19 @@
(SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_EOL))
-/* Older spellings for these nil predicates. */
+
+
+/* Older spellings for these null, nil, and pair predicates. */
#define SCM_NILP(x) (scm_is_eq ((x), SCM_ELISP_NIL))
#define SCM_NULL_OR_NIL_P(x) (scm_is_null_or_nil (x))
+#define SCM_NULLP(x) (scm_is_null (x))
+#define SCM_NNULLP(x) (!scm_is_null (x))
+#define SCM_CONSP(x) (scm_is_pair (x))
+#define SCM_NCONSP(x) (!SCM_CONSP (x))
+
+
/* #nil is null. */
#define scm_is_null(x) (scm_is_null_or_nil(x))
diff --git a/libguile/print.c b/libguile/print.c
index e469277..212b70d 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -751,8 +751,8 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
- case scm_tc7_foreign:
- scm_i_foreign_print (exp, port, pstate);
+ case scm_tc7_pointer:
+ scm_i_pointer_print (exp, port, pstate);
break;
case scm_tc7_hashtable:
scm_i_hashtable_print (exp, port, pstate);
diff --git a/libguile/random.c b/libguile/random.c
index 1a9fd59..c0a3e04 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009, 2010 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
* as published by the Free Software Foundation; either version 3 of
@@ -71,59 +71,34 @@ scm_t_rng scm_the_rng;
* (http://stat.fsu.edu/~geo/diehard.html)
*/
+typedef struct scm_t_i_rstate {
+ scm_t_rstate rstate;
+ scm_t_uint32 w;
+ scm_t_uint32 c;
+} scm_t_i_rstate;
+
+
#define A 2131995753UL
#ifndef M_PI
#define M_PI 3.14159265359
#endif
-#if SCM_HAVE_T_UINT64
-
-unsigned long
-scm_i_uniform32 (scm_t_i_rstate *state)
+static scm_t_uint32
+scm_i_uniform32 (scm_t_rstate *state)
{
- scm_t_uint64 x = (scm_t_uint64) A * state->w + state->c;
+ scm_t_i_rstate *istate = (scm_t_i_rstate*) state;
+ scm_t_uint64 x = (scm_t_uint64) A * istate->w + istate->c;
scm_t_uint32 w = x & 0xffffffffUL;
- state->w = w;
- state->c = x >> 32L;
+ istate->w = w;
+ istate->c = x >> 32L;
return w;
}
-#else
-
-/* ww This is a portable version of the same RNG without 64 bit
- * * aa arithmetic.
- * ----
- * xx It is only intended to provide identical behaviour on
- * xx platforms without 8 byte longs or long longs until
- * xx someone has implemented the routine in assembler code.
- * xxcc
- * ----
- * ccww
- */
-
-#define L(x) ((x) & 0xffff)
-#define H(x) ((x) >> 16)
-
-unsigned long
-scm_i_uniform32 (scm_t_i_rstate *state)
-{
- scm_t_uint32 x1 = L (A) * L (state->w);
- scm_t_uint32 x2 = L (A) * H (state->w);
- scm_t_uint32 x3 = H (A) * L (state->w);
- scm_t_uint32 w = L (x1) + L (state->c);
- scm_t_uint32 m = H (x1) + L (x2) + L (x3) + H (state->c) + H (w);
- scm_t_uint32 x4 = H (A) * H (state->w);
- state->w = w = (L (m) << 16) + L (w);
- state->c = H (x2) + H (x3) + x4 + H (m);
- return w;
-}
-
-#endif
-
-void
-scm_i_init_rstate (scm_t_i_rstate *state, const char *seed, int n)
+static void
+scm_i_init_rstate (scm_t_rstate *state, const char *seed, int n)
{
+ scm_t_i_rstate *istate = (scm_t_i_rstate*) state;
scm_t_uint32 w = 0L;
scm_t_uint32 c = 0L;
int i, m;
@@ -137,18 +112,49 @@ scm_i_init_rstate (scm_t_i_rstate *state, const char
*seed, int n)
}
if ((w == 0 && c == 0) || (w == -1 && c == A - 1))
++c;
- state->w = w;
- state->c = c;
+ istate->w = w;
+ istate->c = c;
}
-scm_t_i_rstate *
-scm_i_copy_rstate (scm_t_i_rstate *state)
+static scm_t_rstate *
+scm_i_copy_rstate (scm_t_rstate *state)
{
scm_t_rstate *new_state;
- new_state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
+ new_state = scm_gc_malloc_pointerless (state->rng->rstate_size,
"random-state");
- return memcpy (new_state, state, scm_the_rng.rstate_size);
+ return memcpy (new_state, state, state->rng->rstate_size);
+}
+
+SCM_SYMBOL(scm_i_rstate_tag, "multiply-with-carry");
+
+static void
+scm_i_rstate_from_datum (scm_t_rstate *state, SCM value)
+#define FUNC_NAME "scm_i_rstate_from_datum"
+{
+ scm_t_i_rstate *istate = (scm_t_i_rstate*) state;
+ scm_t_uint32 w, c;
+ long length;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, value, length);
+ SCM_ASSERT (length == 3, value, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_eq (SCM_CAR (value), scm_i_rstate_tag),
+ value, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_UINT_COPY (SCM_ARG1, SCM_CADR (value), w);
+ SCM_VALIDATE_UINT_COPY (SCM_ARG1, SCM_CADDR (value), c);
+
+ istate->w = w;
+ istate->c = c;
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_rstate_to_datum (scm_t_rstate *state)
+{
+ scm_t_i_rstate *istate = (scm_t_i_rstate*) state;
+ return scm_list_3 (scm_i_rstate_tag,
+ scm_from_uint32 (istate->w),
+ scm_from_uint32 (istate->c));
}
@@ -163,11 +169,24 @@ scm_c_make_rstate (const char *seed, int n)
state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
"random-state");
- state->reserved0 = 0;
- scm_the_rng.init_rstate (state, seed, n);
+ state->rng = &scm_the_rng;
+ state->normal_next = 0.0;
+ state->rng->init_rstate (state, seed, n);
return state;
}
+scm_t_rstate *
+scm_c_rstate_from_datum (SCM datum)
+{
+ scm_t_rstate *state;
+
+ state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
+ "random-state");
+ state->rng = &scm_the_rng;
+ state->normal_next = 0.0;
+ state->rng->from_datum (state, datum);
+ return state;
+}
scm_t_rstate *
scm_c_default_rstate ()
@@ -181,21 +200,24 @@ scm_c_default_rstate ()
#undef FUNC_NAME
-inline double
+double
scm_c_uniform01 (scm_t_rstate *state)
{
- double x = (double) scm_the_rng.random_bits (state) / (double) 0xffffffffUL;
- return ((x + (double) scm_the_rng.random_bits (state))
+ double x = (double) state->rng->random_bits (state) / (double) 0xffffffffUL;
+ return ((x + (double) state->rng->random_bits (state))
/ (double) 0xffffffffUL);
}
double
scm_c_normal01 (scm_t_rstate *state)
{
- if (state->reserved0)
+ if (state->normal_next != 0.0)
{
- state->reserved0 = 0;
- return state->reserved1;
+ double ret = state->normal_next;
+
+ state->normal_next = 0.0;
+
+ return ret;
}
else
{
@@ -205,8 +227,7 @@ scm_c_normal01 (scm_t_rstate *state)
a = 2.0 * M_PI * scm_c_uniform01 (state);
n = r * sin (a);
- state->reserved1 = r * cos (a);
- state->reserved0 = 1;
+ state->normal_next = r * cos (a);
return n;
}
@@ -220,44 +241,39 @@ scm_c_exp1 (scm_t_rstate *state)
unsigned char scm_masktab[256];
-unsigned long
-scm_c_random (scm_t_rstate *state, unsigned long m)
+static inline scm_t_uint32
+scm_i_mask32 (scm_t_uint32 m)
{
- unsigned long r, mask;
-#if SCM_SIZEOF_UNSIGNED_LONG == 4
- mask = (m < 0x100
+ return (m < 0x100
? scm_masktab[m]
: (m < 0x10000
? scm_masktab[m >> 8] << 8 | 0xff
: (m < 0x1000000
? scm_masktab[m >> 16] << 16 | 0xffff
: scm_masktab[m >> 24] << 24 | 0xffffff)));
- while ((r = scm_the_rng.random_bits (state) & mask) >= m);
-#elif SCM_SIZEOF_UNSIGNED_LONG == 8
- mask = (m < 0x100
- ? scm_masktab[m]
- : (m < 0x10000
- ? scm_masktab[m >> 8] << 8 | 0xff
- : (m < 0x1000000
- ? scm_masktab[m >> 16] << 16 | 0xffff
- : (m < (1UL << 32)
- ? scm_masktab[m >> 24] << 24 | 0xffffff
- : (m < (1UL << 40)
- ? ((unsigned long) scm_masktab[m >> 32] << 32
- | 0xffffffffUL)
- : (m < (1UL << 48)
- ? ((unsigned long) scm_masktab[m >> 40] << 40
- | 0xffffffffffUL)
- : (m < (1UL << 56)
- ? ((unsigned long) scm_masktab[m >> 48] << 48
- | 0xffffffffffffUL)
- : ((unsigned long) scm_masktab[m >> 56] << 56
- | 0xffffffffffffffUL))))))));
- while ((r = ((scm_the_rng.random_bits (state) << 32
- | scm_the_rng.random_bits (state))) & mask) >= m);
-#else
-#error "Cannot deal with this platform's unsigned long size"
-#endif
+}
+
+scm_t_uint32
+scm_c_random (scm_t_rstate *state, scm_t_uint32 m)
+{
+ scm_t_uint32 r, mask = scm_i_mask32 (m);
+ while ((r = state->rng->random_bits (state) & mask) >= m);
+ return r;
+}
+
+scm_t_uint64
+scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m)
+{
+ scm_t_uint64 r;
+ scm_t_uint32 mask;
+
+ if (m <= SCM_T_UINT32_MAX)
+ return scm_c_random (state, (scm_t_uint32) m);
+
+ mask = scm_i_mask32 (m >> 32);
+ while ((r = ((scm_t_uint64) (state->rng->random_bits (state) & mask) << 32)
+ | state->rng->random_bits (state)) >= m)
+ ;
return r;
}
@@ -281,24 +297,24 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m)
{
SCM result = scm_i_mkbig ();
const size_t m_bits = mpz_sizeinbase (SCM_I_BIG_MPZ (m), 2);
- /* how many bits would only partially fill the last unsigned long? */
- const size_t end_bits = m_bits % (sizeof (unsigned long) * SCM_CHAR_BIT);
- unsigned long *random_chunks = NULL;
- const unsigned long num_full_chunks =
- m_bits / (sizeof (unsigned long) * SCM_CHAR_BIT);
- const unsigned long num_chunks = num_full_chunks + ((end_bits) ? 1 : 0);
+ /* how many bits would only partially fill the last scm_t_uint32? */
+ const size_t end_bits = m_bits % (sizeof (scm_t_uint32) * SCM_CHAR_BIT);
+ scm_t_uint32 *random_chunks = NULL;
+ const scm_t_uint32 num_full_chunks =
+ m_bits / (sizeof (scm_t_uint32) * SCM_CHAR_BIT);
+ const scm_t_uint32 num_chunks = num_full_chunks + ((end_bits) ? 1 : 0);
/* we know the result will be this big */
mpz_realloc2 (SCM_I_BIG_MPZ (result), m_bits);
random_chunks =
- (unsigned long *) scm_gc_calloc (num_chunks * sizeof (unsigned long),
+ (scm_t_uint32 *) scm_gc_calloc (num_chunks * sizeof (scm_t_uint32),
"random bignum chunks");
do
{
- unsigned long *current_chunk = random_chunks + (num_chunks - 1);
- unsigned long chunks_left = num_chunks;
+ scm_t_uint32 *current_chunk = random_chunks + (num_chunks - 1);
+ scm_t_uint32 chunks_left = num_chunks;
mpz_set_ui (SCM_I_BIG_MPZ (result), 0);
@@ -306,24 +322,24 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m)
{
/* generate a mask with ones in the end_bits position, i.e. if
end_bits is 3, then we'd have a mask of ...0000000111 */
- const unsigned long rndbits = scm_the_rng.random_bits (state);
- int rshift = (sizeof (unsigned long) * SCM_CHAR_BIT) - end_bits;
- unsigned long mask = ((unsigned long) ULONG_MAX) >> rshift;
- unsigned long highest_bits = rndbits & mask;
+ const scm_t_uint32 rndbits = state->rng->random_bits (state);
+ int rshift = (sizeof (scm_t_uint32) * SCM_CHAR_BIT) - end_bits;
+ scm_t_uint32 mask = ((scm_t_uint32)-1) >> rshift;
+ scm_t_uint32 highest_bits = rndbits & mask;
*current_chunk-- = highest_bits;
chunks_left--;
}
while (chunks_left)
{
- /* now fill in the remaining unsigned long sized chunks */
- *current_chunk-- = scm_the_rng.random_bits (state);
+ /* now fill in the remaining scm_t_uint32 sized chunks */
+ *current_chunk-- = state->rng->random_bits (state);
chunks_left--;
}
mpz_import (SCM_I_BIG_MPZ (result),
num_chunks,
-1,
- sizeof (unsigned long),
+ sizeof (scm_t_uint32),
0,
0,
random_chunks);
@@ -331,7 +347,7 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m)
all bits in order not to get a distorted distribution) */
} while (mpz_cmp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (m)) >= 0);
scm_gc_free (random_chunks,
- num_chunks * sizeof (unsigned long),
+ num_chunks * sizeof (scm_t_uint32),
"random bignum chunks");
return scm_i_normbig (result);
}
@@ -376,9 +392,17 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0,
SCM_VALIDATE_RSTATE (2, state);
if (SCM_I_INUMP (n))
{
- unsigned long m = SCM_I_INUM (n);
- SCM_ASSERT_RANGE (1, n, m > 0);
- return scm_from_ulong (scm_c_random (SCM_RSTATE (state), m));
+ unsigned long m = (unsigned long) SCM_I_INUM (n);
+ SCM_ASSERT_RANGE (1, n, SCM_I_INUM (n) > 0);
+#if SCM_SIZEOF_UNSIGNED_LONG <= 4
+ return scm_from_uint32 (scm_c_random (SCM_RSTATE (state),
+ (scm_t_uint32) m));
+#elif SCM_SIZEOF_UNSIGNED_LONG <= 8
+ return scm_from_uint64 (scm_c_random64 (SCM_RSTATE (state),
+ (scm_t_uint64) m));
+#else
+#error "Cannot deal with this platform's unsigned long size"
+#endif
}
SCM_VALIDATE_NIM (1, n);
if (SCM_REALP (n))
@@ -399,7 +423,7 @@ SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0,
1, 0,
if (SCM_UNBNDP (state))
state = SCM_VARIABLE_REF (scm_var_random_state);
SCM_VALIDATE_RSTATE (1, state);
- return make_rstate (scm_the_rng.copy_rstate (SCM_RSTATE (state)));
+ return make_rstate (SCM_RSTATE (state)->rng->copy_rstate (SCM_RSTATE
(state)));
}
#undef FUNC_NAME
@@ -420,6 +444,27 @@ SCM_DEFINE (scm_seed_to_random_state,
"seed->random-state", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_datum_to_random_state, "datum->random-state", 1, 0, 0,
+ (SCM datum),
+ "Return a new random state using @var{datum}, which should have\n"
+ "been obtailed from @code{random-state->datum}.")
+#define FUNC_NAME s_scm_datum_to_random_state
+{
+ return make_rstate (scm_c_rstate_from_datum (datum));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_random_state_to_datum, "random-state->datum", 1, 0, 0,
+ (SCM state),
+ "Return a datum representation of @var{state} that may be\n"
+ "written out and read back with the Scheme reader.")
+#define FUNC_NAME s_scm_random_state_to_datum
+{
+ SCM_VALIDATE_RSTATE (1, state);
+ return SCM_RSTATE (state)->rng->to_datum (SCM_RSTATE (state));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_random_uniform, "random:uniform", 0, 1, 0,
(SCM state),
"Return a uniformly distributed inexact real random number in\n"
@@ -616,9 +661,11 @@ scm_init_random ()
scm_t_rng rng =
{
sizeof (scm_t_i_rstate),
- (unsigned long (*)()) scm_i_uniform32,
- (void (*)()) scm_i_init_rstate,
- (scm_t_rstate *(*)()) scm_i_copy_rstate
+ scm_i_uniform32,
+ scm_i_init_rstate,
+ scm_i_copy_rstate,
+ scm_i_rstate_from_datum,
+ scm_i_rstate_to_datum
};
scm_the_rng = rng;
diff --git a/libguile/random.h b/libguile/random.h
index 6cf404f..2f1f0f6 100644
--- a/libguile/random.h
+++ b/libguile/random.h
@@ -3,7 +3,7 @@
#ifndef SCM_RANDOM_H
#define SCM_RANDOM_H
-/* Copyright (C) 1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2006, 2008, 2010 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
@@ -39,45 +39,35 @@
*/
typedef struct scm_t_rstate {
- int reserved0;
- double reserved1;
+ struct scm_t_rng *rng;
+ double normal_next; /* For scm_c_normal01 */
/* Custom fields follow here */
} scm_t_rstate;
typedef struct scm_t_rng {
size_t rstate_size; /* size of random state */
- unsigned long (*random_bits) (scm_t_rstate *state); /* gives 32 random bits
*/
+ scm_t_uint32 (*random_bits) (scm_t_rstate *state); /* gives 32 random bits */
void (*init_rstate) (scm_t_rstate *state, const char *seed, int n);
scm_t_rstate *(*copy_rstate) (scm_t_rstate *state);
+ void (*from_datum) (scm_t_rstate *state, SCM datum);
+ SCM (*to_datum) (scm_t_rstate *state);
} scm_t_rng;
SCM_API scm_t_rng scm_the_rng;
/*
- * Default RNG
- */
-typedef struct scm_t_i_rstate {
- scm_t_rstate rstate;
- unsigned long w;
- unsigned long c;
-} scm_t_i_rstate;
-
-SCM_INTERNAL unsigned long scm_i_uniform32 (scm_t_i_rstate *);
-SCM_INTERNAL void scm_i_init_rstate (scm_t_i_rstate *, const char *seed, int
n);
-SCM_INTERNAL scm_t_i_rstate *scm_i_copy_rstate (scm_t_i_rstate *);
-
-
-/*
* Random number library functions
*/
SCM_API scm_t_rstate *scm_c_make_rstate (const char *, int);
+SCM_API scm_t_rstate *scm_c_rstate_from_datum (SCM datum);
SCM_API scm_t_rstate *scm_c_default_rstate (void);
-#define scm_c_uniform32(RSTATE) scm_the_rng.random_bits (RSTATE)
+#define scm_c_uniform32(RSTATE) ((RSTATE)->rng->random_bits (RSTATE))
SCM_API double scm_c_uniform01 (scm_t_rstate *);
SCM_API double scm_c_normal01 (scm_t_rstate *);
SCM_API double scm_c_exp1 (scm_t_rstate *);
-SCM_API unsigned long scm_c_random (scm_t_rstate *, unsigned long m);
+SCM_API scm_t_uint32 scm_c_random (scm_t_rstate *, scm_t_uint32 m);
+SCM_API scm_t_uint64 scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m);
SCM_API SCM scm_c_random_bignum (scm_t_rstate *, SCM m);
@@ -94,6 +84,8 @@ SCM_API SCM scm_var_random_state;
SCM_API SCM scm_random (SCM n, SCM state);
SCM_API SCM scm_copy_random_state (SCM state);
SCM_API SCM scm_seed_to_random_state (SCM seed);
+SCM_API SCM scm_datum_to_random_state (SCM datum);
+SCM_API SCM scm_random_state_to_datum (SCM state);
SCM_API SCM scm_random_uniform (SCM state);
SCM_API SCM scm_random_solid_sphere_x (SCM v, SCM state);
SCM_API SCM scm_random_hollow_sphere_x (SCM v, SCM state);
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 360cb94..fcd0173 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -105,7 +105,7 @@ SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME);
\
SCM_SNARF_HERE(
\
static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
SCM_API SCM FNAME ARGLIST; \
- SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \
+ SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign), \
(scm_t_bits) &FNAME); /* the subr */ \
SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
/* FIXME: directly be the foreign */ \
@@ -361,10 +361,8 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
(scm_t_bits) 0, \
(scm_t_bits) sizeof (contents) - 1)
-#define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \
- SCM_IMMUTABLE_CELL (c_name, \
- scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \
- ptr)
+#define SCM_IMMUTABLE_POINTER(c_name, ptr) \
+ SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr)
/* for primitive-generics, add a foreign to the end */
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 85fbc2d..af8126d 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -187,14 +187,10 @@ DEFINE_SRFI_4_PROXIES (s32);
DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1);
DEFINE_SRFI_4_PROXIES (u64);
-#if SCM_HAVE_T_INT64
DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1);
-#endif
DEFINE_SRFI_4_PROXIES (s64);
-#if SCM_HAVE_T_INT64
DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1);
-#endif
DEFINE_SRFI_4_PROXIES (f32);
DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1);
diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h
index 18b1cb1..b55fd1d 100644
--- a/libguile/srfi-4.h
+++ b/libguile/srfi-4.h
@@ -2,7 +2,7 @@
#define SCM_SRFI_4_H
/* srfi-4.c --- Homogeneous numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2008, 2009 Free Software Foundation,
Inc.
+ * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010 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
@@ -161,7 +161,6 @@ SCM_API SCM scm_u64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u64vector (SCM l);
SCM_API SCM scm_any_to_u64vector (SCM obj);
-#if SCM_HAVE_T_UINT64
SCM_API SCM scm_take_u64vector (scm_t_uint64 *data, size_t n);
SCM_API const scm_t_uint64 *scm_array_handle_u64_elements (scm_t_array_handle
*h);
SCM_API scm_t_uint64 *scm_array_handle_u64_writable_elements
(scm_t_array_handle *h);
@@ -173,7 +172,6 @@ SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM
uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
-#endif
SCM_API SCM scm_s64vector_p (SCM obj);
SCM_API SCM scm_make_s64vector (SCM n, SCM fill);
@@ -185,7 +183,6 @@ SCM_API SCM scm_s64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s64vector (SCM l);
SCM_API SCM scm_any_to_s64vector (SCM obj);
-#if SCM_HAVE_T_INT64
SCM_API SCM scm_take_s64vector (scm_t_int64 *data, size_t n);
SCM_API const scm_t_int64 *scm_array_handle_s64_elements (scm_t_array_handle
*h);
SCM_API scm_t_int64 *scm_array_handle_s64_writable_elements
(scm_t_array_handle *h);
@@ -196,7 +193,6 @@ SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM
uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
-#endif
SCM_API SCM scm_f32vector_p (SCM obj);
SCM_API SCM scm_make_f32vector (SCM n, SCM fill);
diff --git a/libguile/symbols.h b/libguile/symbols.h
index e4bc333..8f96d65 100644
--- a/libguile/symbols.h
+++ b/libguile/symbols.h
@@ -3,7 +3,7 @@
#ifndef SCM_SYMBOLS_H
#define SCM_SYMBOLS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2010
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
@@ -36,6 +36,18 @@
+/* Older spellings; don't use in new code.
+ */
+#define SCM_SYMBOLP(x) (scm_is_symbol (x))
+#define SCM_SYMBOL_FUNC(x) (scm_symbol_fref (x))
+#define SCM_SET_SYMBOL_FUNC(x,f) (scm_symbol_fset_x (x, f))
+#define SCM_SYMBOL_PROPS(x) (scm_symbol_pref (x))
+#define SCM_SET_SYMBOL_PROPS(x,p) (scm_symbol_pset_x (x, p))
+#define SCM_SYMBOL_HASH(x) (scm_i_symbol_hash (x))
+#define SCM_SYMBOL_INTERNED_P(x) (scm_i_symbol_is_interned (x))
+
+
+
#ifdef GUILE_DEBUG
SCM_API SCM scm_sys_symbols (void);
#endif
diff --git a/libguile/tags.h b/libguile/tags.h
index d11bf68..9e0e305 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -411,7 +411,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_stringbuf 39
#define scm_tc7_bytevector 77
-#define scm_tc7_foreign 31
+#define scm_tc7_pointer 31
#define scm_tc7_hashtable 29
#define scm_tc7_fluid 37
#define scm_tc7_dynamic_state 45
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 321b499..f9b4fc2 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -533,7 +533,9 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5,
0, 0,
i = scm_to_unsigned_integer (start1, 0, len1);
e = scm_to_unsigned_integer (end1, i, len1);
- j = scm_to_unsigned_integer (start2, 0, len2 - (i-e));
+ SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2);
+ j = scm_to_unsigned_integer (start2, 0, len2);
+ SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
i *= inc1;
e *= inc1;
@@ -571,7 +573,11 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!",
5, 0, 0,
i = scm_to_unsigned_integer (start1, 0, len1);
e = scm_to_unsigned_integer (end1, i, len1);
- j = scm_to_unsigned_integer (start2, 0, len2 - (i-e));
+ SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2);
+ j = scm_to_unsigned_integer (start2, 0, len2);
+ SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
+
+ j += (e - i);
i *= inc1;
e *= inc1;
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7f4641a..ff41ce4 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -140,6 +140,8 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_unbound:
+ /* At this point FINISH_ARGS should be a one-element list containing
+ the name of the unbound variable. */
err_msg = scm_from_locale_string ("VM: Unbound variable: ~s");
goto vm_error;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 3af6308..9ba287d 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -307,10 +307,13 @@ VM_DEFINE_INSTRUCTION (26, variable_ref, "variable-ref",
0, 1, 1)
{
SCM x = *sp;
- if (!VARIABLE_BOUNDP (x))
+ if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
{
- finish_args = scm_list_1 (x);
- /* Was: finish_args = SCM_LIST1 (SCM_CAR (x)); */
+ SCM var_name;
+
+ /* Attempt to provide the variable name in the error message. */
+ var_name = scm_module_reverse_lookup (scm_current_module (), x);
+ finish_args = scm_list_1 (scm_is_true (var_name) ? var_name : x);
goto vm_error_unbound;
}
else
@@ -837,12 +840,13 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1,
1)
VM_DEFINE_INSTRUCTION (56, subr_call, "subr-call", 1, -1, -1)
{
- SCM foreign, ret;
+ SCM pointer, ret;
SCM (*subr)();
+
nargs = FETCH ();
- POP (foreign);
+ POP (pointer);
- subr = SCM_FOREIGN_POINTER (foreign, void);
+ subr = SCM_POINTER_VALUE (pointer);
VM_HANDLE_INTERRUPTS;
SYNC_REGISTER ();
diff --git a/meta/guile-2.0.pc.in b/meta/guile-2.0.pc.in
index c83d821..1280756 100644
--- a/meta/guile-2.0.pc.in
+++ b/meta/guile-2.0.pc.in
@@ -8,7 +8,7 @@ address@hidden@/guile
address@hidden@/guile
address@hidden@
address@hidden@/guile/@GUILE_EFFECTIVE_VERSION@/extensions
address@hidden@/guile/@GUILE_EFFECTIVE_VERSION@/extensions
address@hidden@
Name: GNU Guile
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index e7ef923..d06b230 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1116,7 +1116,7 @@ If there is no handler at all, Guile prints an error and
then exits."
(lambda ()
(let* ((scmstat (stat name))
(gostat (stat go-path #f)))
- (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
+ (if (and gostat (>= (stat:mtime gostat) (stat:mtime scmstat)))
go-path
(begin
(if gostat
diff --git a/module/language/lua/compile-tree-il.scm
b/module/language/lua/compile-tree-il.scm
index e92b585..420b2e1 100644
--- a/module/language/lua/compile-tree-il.scm
+++ b/module/language/lua/compile-tree-il.scm
@@ -1,9 +1,12 @@
;; compile-tree-il.scm --- lua compiler
(define-module (language lua compile-tree-il)
- #:use-module ((system base syntax) #:select (record-case))
#:use-module (language tree-il)
#:use-module ((srfi srfi-1) #:select (map!))
+ #:use-module (srfi srfi-39)
+ #:use-module ((system base syntax) #:select (record-case))
+ #:use-module (rnrs control)
+ #:use-module (language lua common)
#:use-module (language lua parser)
#:use-module (language lua runtime)
@@ -12,6 +15,8 @@
;; utilities
(define *runtime-name* '(language lua runtime))
+(define no-arguments '(() #f #f #f () ()))
+
(define (ref-runtime src name)
(make-module-ref src *runtime-name* name #t))
@@ -35,11 +40,19 @@
(define (apply-named-lua-function src name get-body)
(let* ((name (gensym (string-append " " name)))
(parameters (list name)))
- (make-let
+ (make-application
src
- parameters parameters
- (list (make-lambda src '() (get-body name)))
- (make-application src (make-lexical-ref src name name) '()))))
+ (make-module-ref src '(guile) 'catch #t)
+ (list
+ (make-const src 'lua-break)
+ (make-argless-lambda src
+ (make-let
+ src
+ parameters parameters
+ (list (make-lambda src '() (get-body name)))
+ (make-application src (make-lexical-ref src name name) '())))
+ (make-arg-ignoring-lambda src
+ (make-void src))))))
(define (while-loop->tree-il src condition body)
"Create a WHILE loop, used by both WHILE and REPEAT."
@@ -60,6 +73,9 @@
(define (make-plain-lambda src args gensyms body . alternate)
(make-lambda src '() (apply make-plain-lambda-case (append (list src args
gensyms body) alternate))))
+(define (make-arg-ignoring-lambda src body)
+ (make-lambda src '() (make-lambda-case src '() #f '_ #f '() (list (gensym
"_")) body #f)))
+
(define (make-argless-lambda src body)
(make-plain-lambda src '() #f body))
@@ -71,7 +87,7 @@
#t
'(%adjust)
(list adjust-gensym)
- (list
+ (list
(make-plain-lambda
src
'(%value)
@@ -84,17 +100,19 @@
;; main compiler
-(define* (compile ctx exp #:optional last-in-list?)
- (define* (map-compile ctx exps #:optional care-about-last?)
+(define context (make-parameter #f))
+
+(define* (compile exp #:optional last-in-list?)
+ (define* (map-compile exps #:optional care-about-last?)
(let lp ((ls exps)
(tree '()))
(if (null? ls)
(reverse! tree)
- (lp (cdr ls) (append! (list (compile ctx (car ls) (and
care-about-last? (null? (cdr ls))))) tree)))))
+ (lp (cdr ls) (append! (list (compile (car ls) (and care-about-last?
(null? (cdr ls))))) tree)))))
(record-case exp
((ast-sequence src exps)
- (make-sequence src (map-compile #f exps)))
+ (make-sequence src (map-compile exps)))
((ast-literal src exp)
(if (eq? exp *unspecified*)
@@ -105,62 +123,173 @@
(make-application src (make-primitive-ref src 'return)
(list (make-application src
(make-primitive-ref src 'values)
- (if (list? exp) (map-compile #f exp #t) (list (compile #f
exp)))))))
+ (if (list? exp) (map-compile exp #t) (list (compile exp)))))))
+
((ast-function src name arguments argument-gensyms variable-arguments?
body)
;; ... is always attached because lua functions must ignore
- ;; variable arguments; the parser will catch when ... is improperly
- ;; used
- (make-lambda src (if name `((name . ,name)) '()) (make-lambda-case src
'() arguments '... #f (map (lambda (x) (make-const src #nil)) arguments)
(append! argument-gensyms (list '...)) (compile #f body) #f)))
-
-#| ((ast-function-call src operator operands)
- (let* ((proc (compile #f operator))
- (args (make-application src (make-primitive-ref src 'list)
(map-compile #f operands)))
- (app-args (make-application src (make-primitive-ref src 'cons)
(list proc args)))
- (app (make-application src (make-primitive-ref src 'apply) (list
app-args))))
-; (if last-in-list? app (adjust-to-single-value src app))))
- app))
-#| (let* ((proc (compile #f operator))
- (args (map-compile #f operands))
- (app (make-application src (make-primitive-ref src 'apply)
(make-application (make-primitive-ref proc args))))
- (if last-in-list?
- app
- (adjust-to-single-value src app)))
- )
-|#
- |#
+ ;; variable arguments; the parser will catch it if ... is used in a
+ ;; function that doesn't have ... in the parameter list
+ (make-lambda src (if name `((name . ,name)) '()) (make-lambda-case src
'() arguments '... #f (map (lambda (x) (make-const src #nil)) arguments)
(append! argument-gensyms (list '...)) (compile body) #f)))
+
((ast-function-call src operator operands)
- (let* ((proc (compile #f operator))
- (args (make-application src (make-primitive-ref src 'list)
(map-compile #f operands)))
+ #| (let* ((proc (compile operator))
+ (args (make-application src (make-primitive-ref src 'list)
(map-compile operands)))
(app-args (make-application src (make-primitive-ref src 'list)
(list proc args)))
- (app (make-application src (make-primitive-ref src 'apply) (list
(make-primitive-ref src 'apply) app-args))))
- app))
+ (app (make-application src (make-primitive-ref src 'apply) (list
(make-primitive-ref src 'apply) app-args)))) |#
+ (let* ((proc (compile operator))
+ (app (make-application src proc (map-compile operands))))
+ (if (ast-global-ref? operator)
+ (make-sequence src (list
+ (make-application src (make-module-ref src
'(language lua runtime) 'check-global-function #t)
+ (list (make-const src
(ast-global-ref-name operator))
+ proc))
+ app))
+ app)))
((ast-local-block src names gensyms initial-values exp)
- (make-let src names gensyms (map-compile #f initial-values) (compile #f
exp)))
+ (make-let src names gensyms (map-compile initial-values) (compile exp)))
((ast-local-ref src name gensym)
(make-lexical-ref src name gensym))
((ast-local-set src name gensym exp)
- (make-lexical-set src name gensym (compile #f exp)))
+ (make-lexical-set src name gensym (compile exp)))
((ast-global-ref src name)
(make-table-ref src (ref-runtime src '*global-env-table*) name))
((ast-global-set src name exp)
- (make-table-set! src (ref-runtime src '*global-env-table*) name (compile
#f exp)))
+ (make-table-set! src (ref-runtime src '*global-env-table*) name (compile
exp)))
((ast-table-ref src table key)
- (make-table-ref src (compile #f table) (compile #f key)))
+ (make-table-ref src (compile table) (compile key)))
((ast-table-set src table key exp)
- (make-table-set! src (compile #f table) (compile #f key) (compile #f
exp)))
+ (make-table-set! src (compile table) (compile key) (compile exp)))
((ast-condition src test then else)
- (make-conditional src (compile #f test) (compile #f then) (compile #f
else)))
+ (make-conditional src (compile test) (compile then) (compile else)))
((ast-while-loop src condition body)
- (while-loop->tree-il src (compile #f condition) (compile #f body)))
+ (parameterize
+ ((context 'while-loop))
+ (while-loop->tree-il src (compile condition) (compile body))))
+
+ ;; TODO: in order for this to have the same semantics as lua, all
+ ;; potential subforms of while should introduce their own context,
+ ;; so you can't use break inside of a function inside a while loop
+ ;; for instance
+ ((ast-break src)
+ (unless (or-eqv? (context) 'while-loop 'list-for-loop 'numeric-for-loop)
+ (syntax-error src "no loop to break"))
+ (make-application src (make-module-ref src '(guile) 'throw #t) (list
(make-const src 'lua-break)))
+ )
+
+ ((ast-list-for-loop src names exps body)
+ (let* ((gs-iterator (gensym "iterator"))
+ (gs-state (gensym "state"))
+ (gs-variable (gensym "variable"))
+ (gs-iterator2 (gensym "iterator"))
+ (gs-state2 (gensym "state"))
+ (gs-variable2 (gensym "variable"))
+ (gs-loop (gensym "loop"))
+ (gs-names (map gensym (map symbol->string names))))
+ (parse-tree-il
+ `(letrec*
+ ;; names
+ (iterator state variable loop)
+ ;; gensyms
+ (,gs-iterator ,gs-state ,gs-variable ,gs-loop)
+ ;; vals
+ ((void) (void) (void)
+ (lambda ()
+ (lambda-case
+ (,no-arguments
+ (begin
+ ;; even more complicated, assigning the values to the loop
variables
+ (apply (primitive call-with-values)
+ (lambda () (lambda-case (,no-arguments (apply
(lexical iterator ,gs-iterator) (lexical state ,gs-state) (lexical variable
,gs-variable)))))
+ (lambda () (lambda-case ((,names #f #f #f ()
,gs-names)
+ ;; almost to the actual loop body, hang in there
+ (begin
+ (set! (lexical variable ,gs-variable) (lexical
,(car names) ,(car gs-names)))
+ (if (apply (primitive eq?) (lexical variable
,gs-variable) (const #nil))
+ (apply (@ (guile) throw) (const 'lua-break))
+ (void))
+ ,(parameterize ((context 'list-for-loop))
(unparse-tree-il (compile body)))))))))))))
+ ;; initialize variables and start loop
+ (begin
+ (apply (primitive call-with-values)
+ (lambda () (lambda-case (,no-arguments ,(unparse-tree-il
(make-sequence #f (map-compile exps))))))
+ (lambda () (lambda-case (((iterator state variable) #f #f
#f () (,gs-iterator2 ,gs-state2 ,gs-variable2))
+ (begin
+ (set! (lexical iterator
,gs-iterator) (lexical iterator ,gs-iterator2))
+ (set! (lexical state ,gs-state)
(lexical state ,gs-state2))
+ (set! (lexical variable
,gs-variable) (lexical variable ,gs-variable2)))))))
+ (apply (@ (guile) catch)
+ (const lua-break)
+ (lambda () (lambda-case (,no-arguments
+ (apply (lexical loop ,gs-loop)))))
+ (lambda () (lambda-case (,no-arguments (void))))))))))
+
+ ;; TODO: in order for this to have the same semantics as lua, all
+ ;; potential subforms of while should introduce their own context,
+ ;; so you can't use break inside of a function inside a while loop
+ ;; for instance
+
+ ((ast-numeric-for-loop src named initial limit step body)
+ ;; as per 5.1 manual 2.4.5, the numeric for loop can be decomposed into
simpler forms
+ ;; still doesn't have proper behavior, should be able to return and break
inside a loop
+ (let* ((gs-named (gensym (symbol->string named)))
+ (gs-variable (gensym "variable"))
+ (gs-limit (gensym "limit"))
+ (gs-step (gensym "step"))
+ (gs-loop (gensym "loop"))
+ (while-condition
+ `(if (apply (primitive >) (lexical step ,gs-step) (const 0))
+ (if (apply (primitive <=) (lexical variable ,gs-variable)
(lexical limit ,gs-limit))
+ (apply (lexical loop ,gs-loop))
+ (void))
+ (void))))
+ (parse-tree-il
+ `(letrec*
+ ;; names
+ (,named variable limit step loop)
+ ;; gensyms
+ (,gs-named ,gs-variable ,gs-limit ,gs-step ,gs-loop)
+ ;; vals
+ ,(cons
+ '(const #f)
+ (append
+ (map (lambda (x) `(apply (@ (language lua runtime) tonumber)
,(unparse-tree-il (compile x)))) (list initial limit step))
+ ;; loop body
+ (list
+ `(lambda ()
+ (lambda-case
+ ;; no arguments
+ ((() #f #f #f () ())
+ ;; body
+ (begin
+ (set! (lexical ,named ,gs-named) (lexical variable
,gs-variable))
+ ,(parameterize ((context 'numeric-for-loop))
(unparse-tree-il (compile body)))
+ (set! (lexical variable ,gs-variable) (apply (primitive
+) (lexical variable ,gs-variable) (lexical step ,gs-step)))
+ ,while-condition
+ )))))))
+ ;; body
+ (begin
+ ;; if not (var and limit and step) then error() end
+ (if (apply (primitive not)
+ (if (apply (@ (language lua runtime) true?) (lexical
variable ,gs-variable))
+ (if (apply (@ (language lua runtime) true?)
(lexical limit ,gs-limit))
+ (if (apply (@ (language lua runtime) true?)
(lexical step ,gs-step))
+ (const #t)
+ (const #f))
+ (const #f))
+ (const #f)))
+ (apply (@ (guile) error))
+ (void))
+ ,while-condition
+ )))))
((ast-table-literal src fields)
(let* ((table (make-runtime-application src 'make-table '())))
@@ -179,8 +308,8 @@
(append!
(map
(lambda (x)
- (let* ((key (compile #f (car x)))
- (value (compile #f (cdr x))))
+ (let* ((key (compile (car x)))
+ (value (compile (cdr x))))
(make-runtime-application src 'new-index! (list
(make-lexical-ref src temp-name temp-name) key value))))
fields)
(list ref)))))
@@ -197,11 +326,11 @@
((#\-) (ref-runtime src 'unm))
((#\#) (ref-runtime src 'len))
((not) (make-primitive-ref src 'not)))
- (list (compile src right)))))
+ (list (compile right)))))
((ast-binary-operation src operator left right)
- (let ((left (compile #f left))
- (right (compile #f right)))
+ (let ((left (compile left))
+ (right (compile right)))
(case operator
((#\+ #\- #\* #\/ #\^ #\< #\> #:<= #:>= #:== #:~= #:concat)
(let* ((result
@@ -243,4 +372,6 @@
;; exported compiler function
(define (compile-tree-il exp env opts)
- (values (compile #f exp) env env))
+ (parameterize
+ ((context #f))
+ (values (compile exp) env env)))
diff --git a/module/language/lua/lexer.scm b/module/language/lua/lexer.scm
index 75fb7e0..672a943 100644
--- a/module/language/lua/lexer.scm
+++ b/module/language/lua/lexer.scm
@@ -40,7 +40,7 @@
(define (possible-keyword token)
"Convert a symbol to a keyword if it is a reserved word in Lua"
- (if (or-eqv? token '(return function end if then elseif else true false nil
or and do while repeat until local))
+ (if (or-eqv? token '(return function end if then elseif else true false nil
or and do while repeat until local for break in not))
(symbol->keyword token)
token))
@@ -314,5 +314,4 @@ of an identifier"
(receive (get-source-info lex)
(make-lexer port)
(set! a get-source-info)
- (set! b lex)))))
-
+ (set! b lex)))))
\ No newline at end of file
diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm
index 53cf270..7b96785 100644
--- a/module/language/lua/parser.scm
+++ b/module/language/lua/parser.scm
@@ -84,6 +84,9 @@
(table-set table key exp)
(table-literal fields)
(while-loop condition body)
+ (numeric-for-loop named initial limit step body)
+ (list-for-loop names exps body)
+ (break)
(function name arguments argument-gensyms variable-arguments? body)
(function-call operator operands)
(binary-operation operator left right)
@@ -94,6 +97,7 @@
;; Constants
(define *nil-literal* (make-ast-literal #f #nil))
(define *void-literal* (make-ast-literal #f *unspecified*))
+(define *default-for-step* (make-ast-literal #f 1))
(define (end-of-chunk? token)
"Returns true if TOKEN denotes the end of a grammatical chunk."
@@ -108,8 +112,8 @@
(case t
((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\#
#:function #:end #:if #:return #:elseif #:then #:else #:true #:false
-#:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots) t)
- (else (error #:TOKEN/TYPE t))))))
+#:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots #:break #:do #:in) t)
+ (else (error 'TOKEN/TYPE t))))))
;; infix operator parsing
(define (binary-operator? t)
@@ -144,7 +148,7 @@
((ast-table-ref? left)
(make-ast-table-set (ast-table-ref-src left) (ast-table-ref-table
left) (ast-table-ref-key left) right))
(else
- (error #:MAKE-LUA-ASSIGNMENT "should not happen"))))
+ (error 'MAKE-LUA-ASSIGNMENT "should not happen"))))
(define (wrap-expression-in-environment src e x)
"Wrap an expression in an enclosing lexical environment if necessary"
@@ -184,10 +188,11 @@
(define (leave-environment!)
"Set ENVIRONMENT to the current ENVIRONMENT's parent"
(if (not environment)
- (error #:LEAVE-ENVIRONMENT! "should not happen"))
+ (error 'LEAVE-ENVIRONMENT! "should not happen"))
(set! environment
(environment-parent environment)))
+ ;; Type may be 'parameter or 'local
(define (environment-define! name type)
"Define a new variable with NAME and TYPE"
(if (not (member name (environment-bindings environment)))
@@ -302,7 +307,7 @@
;; ')'
(enforce-next! #\))
arguments)))
- (else (error #:APPLICATION-ARGUMENTS "should not happen"))))
+ (else (error 'APPLICATION-ARGUMENTS "should not happen"))))
;; prefix-expression -> NAME | '(' expression ')'
(define (prefix-expression)
@@ -605,7 +610,7 @@
(if (null? rest)
(reverse! (append! (list il) tree))
(loop (append! (list il) tree) (cdr rest))))))
- (else (error #:PARSE-ASSIGNMENT "should not happen"))))))
+ (else (error 'PARSE-ASSIGNMENT "should not happen"))))))
;; assignment -> '=' expression-list | ',' primary-expression assignment
(define (assignment first)
@@ -702,7 +707,7 @@
((table-function table-method)
(make-ast-table-set src (cdr prefix) (make-ast-literal src
(symbol->string (car prefix))) body))
((function) (make-lua-assignment prefix body))
- (else (error #:FUNCTION-STATEMENT "should not happen")))))
+ (else (error 'FUNCTION-STATEMENT "should not happen")))))
;; local-statement -> LOCAL NAME { ',' NAME } [ '=' expression-list ]
(define (local-statement)
@@ -735,13 +740,82 @@
(advance!)
(make-ast-local-set (get-source-info) name (environment-lookup-gensym
name) (function-body))))
+ ;; for-body
+ (define (for-body)
+ (enforce-next! #:do)
+ (let* ((body (chunk)))
+ (enforce-next! #:end)
+ body))
+
+ ;; numeric-for -> FOR NAME '=' expression ',' expression ',' expression DO
chunk END
+ (define (numeric-for src name)
+ (define step *default-for-step*)
+ (enforce-next! #:=)
+ (enter-environment!)
+ (environment-define! name 'local)
+ (let* ((initial (expression)))
+ (enforce-next! #\,)
+ (let* ((limit (expression)))
+ (when (eq? token #\,)
+ (advance!)
+ (set! step (expression)))
+ (let* ((result (make-ast-numeric-for-loop src name initial limit step
(for-body))))
+ (leave-environment!)
+ result))))
+
+ ;; list-for -> FOR NAME { ',' NAME } IN expression-list DO chunk END
+ (define (list-for src name)
+ (when (eq? token #\,)
+ (advance!))
+ (let* ((names
+ (let lp ((names (list name)))
+ (advance!)
+ (if (eq? token #\,)
+ (begin
+ (advance!)
+ (assert-token-type 'NAME)
+ (lp (cons token names)))
+ (reverse! names)))))
+ (enforce-next! #:in)
+ (let* ((exps (expression-list)))
+ (enforce-next! #:do)
+ (let* ((body (chunk)))
+ (enforce-next! #:end)
+ (make-ast-list-for-loop src names exps body)))))
+
+ ;; for-statement -> FOR (numeric-for | list-for) END
+ (define (for-statement)
+ (define src (get-source-info))
+ (enforce-next! #:for)
+ (assert-token-type 'NAME)
+ (let* ((name token)
+ (result
+ (begin
+ (advance!)
+ (if (eq? token #:=)
+ (numeric-for src name)
+ (if (or-eqv? token #:in #\,)
+ (list-for src name)
+ (syntax-error src "expected = or in after for
variable"))))))
+ result))
+
+ ;; break-statement -> BREAK
+ (define (break-statement)
+ (enforce-next! #:break)
+ (make-ast-break (get-source-info)))
+
;; statement
(define (statement)
(case token
((#\;) (advance!) (statement))
;; statement -> return
- ((#:return) (values #t (return-statement)))
- ((#:if #:function #:do #:while #:repeat #:local)
+ ((#:return #:break)
+ (values
+ #t
+ (case token
+ ((#:return) (return-statement))
+ ((#:break) (break-statement)))))
+ ((#:if #:function #:do #:while #:repeat #:local #:for)
(values
#f
(case token
@@ -754,6 +828,7 @@
(if (maybe-skip-next! #:function)
(local-function-statement)
(local-statement)))
+ ((#:for) (for-statement))
((#:do)
(begin
(advance!)
@@ -791,4 +866,3 @@
(define (read-lua port)
(define parser (make-parser port))
(parser))
-
diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm
index 7842db8..921ecd0 100644
--- a/module/language/lua/runtime.scm
+++ b/module/language/lua/runtime.scm
@@ -8,6 +8,7 @@
#:use-module (srfi srfi-9)
#:use-module ((srfi srfi-69) #:renamer (lambda (s) (if (eq? s
'make-hash-table) 'srfi-69-make-hash-table s)))
#:use-module ((srfi srfi-98) #:select (get-environment-variable))
+ #:use-module ((system base compile) #:select (compile))
#:export (
runtime-error
@@ -54,6 +55,8 @@
;; global environment
*global-env-table*
+ save-fenv
+ check-global-function
)
#:export-syntax (table-slots table? table-metatable table-metatable!)
@@ -64,12 +67,12 @@
;; eval: (put 'define-global 'scheme-indent-function 1)
;; End:
-(define (runtime-error message)
+(define (runtime-error string . arguments)
"Throw an error tagged with 'lua-runtime"
- (throw 'lua-runtime message))
+ (throw 'lua-runtime (apply format (cons (string-append "LUA: ERROR: " string
"\n") arguments))))
(define (runtime-warning string . arguments)
- (format #t (string-append "GUILE-LUA: RUNTIME WARNING: " string) arguments))
+ (apply format (cons #t (cons (string-append "LUA: RUNTIME WARNING: " string
"\n") arguments))))
;;;;; SEMANTICS
@@ -282,6 +285,18 @@
(define *global-env-table* (make-table))
+;; Saves _G and returns a function that will restore it
+(define (save-fenv table)
+ "Saves *global-env-table* and returns a function to restore it"
+ (let* ((save *global-env-table*))
+ (set! *global-env-table* table)
+ (lambda ()
+ (set! *global-env-table* save))))
+
+(define (check-global-function name value)
+ (when (eq? value #nil)
+ (runtime-error "attempt to call global '~a' (a nil value)" name)))
+
;;;;; BUILT-INS
(define-syntax define-global
@@ -322,7 +337,9 @@
(define-global (dofile filename)
(assert-string 1 "dofile" filename)
(runtime-warning "dofile cannot return the values of the chunk and instead
will return #nil")
- (runtime-warning "UNIMPLEMENTED")
+ (call-with-input-file filename
+ (lambda (file)
+ (compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to
'value)))
#nil)
;; TODO: error(message, [level])
@@ -330,8 +347,6 @@
;; global variable table
(define-global _G *global-env-table*)
-;; TODO: getfenv
-
(define-global (getmetatable table)
(assert-table 1 "getmetatable" table)
(let* ((mt (table-metatable table)))
@@ -339,18 +354,50 @@
#nil
mt)))
-#;(define-global (ipairs table)
+(define-global (ipairs table)
(assert-table 1 "ipairs" table)
(values
- (lambda ()
+ (lambda (t i)
+ (set! i (+ i 1))
+
)
table
0))
-;; TODO: ipairs
-;; TODO: load
-;; TODO: loadfile
+(define (load-warning)
+ (runtime-warning "load, loadfile, and loadstring cannot return the results
of evaluating a file"))
+
+(define (load-chunkname-warning chunkname)
+ (when chunkname
+ (runtime-warning "load and loadstring ignore chunkname")))
+
+(define-global load
+ (lambda* (func #:optional chunkname)
+ (load-warning)
+ (load-chunkname-warning chunkname)
+ (lambda ()
+ (compile
+ ((@ (language lua parser) read-lua)
+ (open-input-string
+ (let lp ((tree '())
+ (result (func)))
+ (if (or (equal? func "") (eq? func #nil) (eq? func *unspecified*))
+ (reduce-right string-append '() (reverse! tree))
+ (lp (cons func tree) (func))))))
+ #:from 'lua #:to 'value))))
+
+(define-global loadfile
+ (lambda* (#:optional filename)
+ (load-warning)
+ (lambda ()
+ (if filename
+ (call-with-input-file filename
+ (lambda (file)
+ (compile ((@ (language lua parser) read-lua) file) #:from 'lua
#:to 'value)))
+ (read-and-compile (current-input-port) #:from 'lua)))))
+
;; TODO: loadstring
+
;; TODO: module
;; TODO: next(table [, index])
;; TODO: pairs
@@ -376,7 +423,7 @@
(assert-table 1 "rawset" table)
(hash-table-set! (table-slots table) key value))
-;; TODO: setfenv
+;; TODO: select
(define-global (setmetatable table metatable)
(assert-table 1 "setmetatable" table)
@@ -394,15 +441,13 @@
(string->number e base))
(else #nil)))
-
-;; NOTE: tostring does not check for __tostring
(define-global (tostring e)
(cond ((string? e) e)
((eqv? e #t) "true")
((eqv? e #f) "false")
((eqv? e #nil) "nil")
((number? e) (number->string e))
- ((table? e)
+ ((might-have-metatable? e)
(dispatch-metatable-event
"__tostring"
(lambda (table) (format "~A" e))
@@ -417,7 +462,7 @@
;; _VERSION
;; contains a string describing the lua version
-(define-global _VERSION "Guile-Lua 5.1")
+(define-global _VERSION "Guile/Lua 5.1")
;; TODO: xpcall
diff --git a/module/language/lua/spec.scm b/module/language/lua/spec.scm
index fa19ecc..8aa3ee5 100644
--- a/module/language/lua/spec.scm
+++ b/module/language/lua/spec.scm
@@ -9,6 +9,8 @@
(define-language lua
#:title "Lua"
- #:reader (lambda (port _) (read-lua port))
+ #:reader (lambda (port _)
+ (if (file-port? port)
+ (read-lua port)))
#:compilers `((tree-il . ,compile-tree-il))
#:printer write)
diff --git a/module/rnrs.scm b/module/rnrs.scm
index eb2ea85..1c07e40 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -52,7 +52,7 @@
boolean? symbol? char? vector? null? pair? number? string? procedure?
define define-syntax syntax-rules lambda let let* let-values
- let*-values letrec begin quote lambda if set! cond case or and not
+ let*-values letrec letrec* begin quote lambda if set! cond case or
and not
eqv? equal? eq? + - * / max min abs numerator denominator gcd lcm
floor ceiling truncate round rationalize real-part imag-part
make-rectangular angle div mod div-and-mod div0 mod0 div0-and-mod0
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 4358aa4..e92089e 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -21,7 +21,7 @@
(export boolean? symbol? char? vector? null? pair? number? string? procedure?
define define-syntax syntax-rules lambda let let* let-values
- let*-values letrec begin
+ let*-values letrec letrec* begin
quote lambda if set! cond case
@@ -72,10 +72,13 @@
syntax-rules identifier-syntax)
(import (rename (guile) (quotient div) (modulo mod))
- (rename (only (guile) for-each map)
- (for-each vector-for-each) (map vector-map))
(srfi srfi-11))
+ (define (vector-for-each proc . vecs)
+ (apply for-each (cons proc (map vector->list vecs))))
+ (define (vector-map proc . vecs)
+ (list->vector (apply map (cons proc (map vector->list vecs)))))
+
(define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r)))
(define (div0 x y)
diff --git a/module/rnrs/lists.scm b/module/rnrs/lists.scm
index c9d913b..812ce5f 100644
--- a/module/rnrs/lists.scm
+++ b/module/rnrs/lists.scm
@@ -44,6 +44,6 @@
(define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
(define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))
- (define (memp pred list) (memp-internal #f list pred))
- (define (assp pred list) (assp-internal #f list pred))
+ (define (memp pred list) (memp-internal #f list (lambda (x y) (pred y))))
+ (define (assp pred list) (assp-internal #f list (lambda (x y) (pred y))))
)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index d553975..29c8d52 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -81,11 +81,6 @@
(proc tmp)
(chmod tmp (logand #o0666 (lognot (umask))))
(close-port tmp)
- (if reference
- (let ((st (stat reference)))
- (utime template
- (stat:atime st) (stat:mtime st)
- (stat:atimensec st) (stat:mtimensec st))))
(rename-file template filename))
(lambda args
(delete-file template)))))))
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 692dd92..121db60 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -18,6 +18,7 @@
(define-module (system foreign)
#:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
#:export (void
float double
int unsigned-int long unsigned-long size_t
@@ -25,19 +26,40 @@
uint16 int16
uint32 int32
uint64 int64
- %null-pointer
sizeof alignof
- foreign-ref foreign-set!
- foreign->bytevector bytevector->foreign
- foreign-set-finalizer!
+ %null-pointer
+ null-pointer?
+ make-pointer
+ pointer-address
+ dereference-pointer
+
+ pointer->bytevector
+ bytevector->pointer
+ set-pointer-finalizer!
+
make-foreign-function
make-c-struct parse-c-struct))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_foreign")
+
+;;;
+;;; Pointers.
+;;;
+
+(define (null-pointer? pointer)
+ "Return true if POINTER is the null pointer."
+ (= (pointer-address pointer) 0))
+
+
+
+;;;
+;;; Structures.
+;;;
+
(define *writers*
`((,float . ,bytevector-ieee-single-native-set!)
(,double . ,bytevector-ieee-double-native-set!)
@@ -100,7 +122,11 @@
(define (make-c-struct types vals)
(let ((bv (make-bytevector (sizeof types) 0)))
(write-c-struct bv 0 types vals)
- (bytevector->foreign bv)))
+ (bytevector->pointer bv)))
(define (parse-c-struct foreign types)
- (read-c-struct (foreign->bytevector foreign) 0 types))
+ (let ((size (fold (lambda (type total)
+ (+ (sizeof type) total))
+ 0
+ types)))
+ (read-c-struct (pointer->bytevector foreign size) 0 types)))
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 01b1b4c..293b790 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -195,7 +195,11 @@
v))
(define (narrow-stack->vector stack . args)
- (stack->vector (apply make-stack (stack-ref stack 0) args)))
+ (let ((narrowed (apply make-stack (stack-ref stack 0) args)))
+ (if narrowed
+ (stack->vector narrowed)
+ #()))) ; ? Can be the case for a tail-call to `throw' tho
+
;; (define (debug)
;; (run-debugger
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 21998ba..9e364dd 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -121,10 +121,20 @@
(cond
((eqv? exp *unspecified*)) ; read error, pass
((eq? exp meta-command-token)
- (catch 'quit
- (lambda () (meta-command repl))
+ (catch #t
+ (lambda ()
+ (meta-command repl))
(lambda (k . args)
- (abort args))))
+ (if (eq? k 'quit)
+ (abort args)
+ (begin
+ (format #t "While executing meta-command:~%" string)
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (display-error #f (current-output-port) subr msg
args rest))
+ (else
+ (format #t "ERROR: Throw to key `~a' with args
`~s'.\n" key args)))
+ (force-output))))))
((eof-object? exp)
(newline)
(abort '()))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 9b52e3b..eab1cd5 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -80,6 +80,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-arithmetic-bitwise.test \
tests/r6rs-arithmetic-fixnums.test \
tests/r6rs-arithmetic-flonums.test \
+ tests/r6rs-base.test \
tests/r6rs-conditions.test \
tests/r6rs-control.test \
tests/r6rs-enums.test \
@@ -87,6 +88,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-exceptions.test \
tests/r6rs-files.test \
tests/r6rs-hashtables.test \
+ tests/r6rs-lists.test \
tests/r6rs-ports.test \
tests/r6rs-records-inspection.test \
tests/r6rs-records-procedural.test \
diff --git a/test-suite/standalone/test-conversion.c
b/test-suite/standalone/test-conversion.c
index 1887d33..4480125 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/test-suite/standalone/test-conversion.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009, 2010 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
@@ -702,10 +702,8 @@ DEFSTST (scm_to_int16)
DEFUTST (scm_to_uint16)
DEFSTST (scm_to_int32)
DEFUTST (scm_to_uint32)
-#ifdef SCM_HAVE_T_INT64
DEFSTST (scm_to_int64)
DEFUTST (scm_to_uint64)
-#endif
#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te)
#define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te)
@@ -745,11 +743,9 @@ test_int_sizes ()
TEST_7S (scm_from_int32, SCM_T_INT32_MAX+1LL, "-2147483648");
TEST_7U (scm_from_uint32, SCM_T_UINT32_MAX, "4294967295");
-#if SCM_HAVE_T_INT64
TEST_7S (scm_from_int64, SCM_T_INT64_MIN, "-9223372036854775808");
TEST_7S (scm_from_int64, SCM_T_INT64_MAX, "9223372036854775807");
TEST_7U (scm_from_uint64, SCM_T_UINT64_MAX, "18446744073709551615");
-#endif
TEST_8S ("91", scm_to_schar, 91, 0, 0);
TEST_8U ("91", scm_to_uchar, 91, 0, 0);
@@ -794,7 +790,6 @@ test_int_sizes ()
TEST_8U ("-1", scm_to_uint32, 0, 1, 0);
TEST_8U ("#f", scm_to_uint32, 0, 0, 1);
-#if SCM_HAVE_T_INT64
TEST_8S ("-9223372036854775808", scm_to_int64, SCM_T_INT64_MIN, 0, 0);
TEST_8S ("9223372036854775807", scm_to_int64, SCM_T_INT64_MAX, 0, 0);
TEST_8S ("9223372036854775808", scm_to_int64, 0, 1, 0);
@@ -803,7 +798,6 @@ test_int_sizes ()
TEST_8U ("18446744073709551616", scm_to_uint64, 0, 1, 0);
TEST_8U ("-1", scm_to_uint64, 0, 1, 0);
TEST_8U ("#f", scm_to_uint64, 0, 0, 1);
-#endif
}
diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi
index 7c859f2..5918a73 100755
--- a/test-suite/standalone/test-ffi
+++ b/test-suite/standalone/test-ffi
@@ -165,12 +165,13 @@ exec guile -q -s "$0" "$@"
(define f-memcpy
(make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib)
(list '* '* int32)))
-(let* ((src (bytevector->foreign (u8-list->bytevector '(0 1 2 3 4 5 6 7))))
- (dest (bytevector->foreign (make-bytevector 16 0)))
- (res (f-memcpy dest src (bytevector-length (foreign->bytevector src)))))
- (or (= (foreign-ref dest) (foreign-ref res))
+(let* ((src* '(0 1 2 3 4 5 6 7))
+ (src (bytevector->pointer (u8-list->bytevector src*)))
+ (dest (bytevector->pointer (make-bytevector 16 0)))
+ (res (f-memcpy dest src (length src*))))
+ (or (= (pointer-address dest) (pointer-address res))
(error "memcpy res not equal to dest"))
- (or (equal? (bytevector->u8-list (foreign->bytevector dest))
+ (or (equal? (bytevector->u8-list (pointer->bytevector dest 16))
'(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
(error "unexpected dest")))
@@ -196,7 +197,7 @@ exec guile -q -s "$0" "$@"
(let* ((ptr (strerror ENOENT))
(len (strlen ptr))
- (bv (foreign->bytevector ptr 'u8 0 len))
+ (bv (pointer->bytevector ptr len 0 'u8))
(str (utf8->string bv)))
(test #t (not (not (string-contains str "file")))))
diff --git a/test-suite/standalone/test-num2integral.c
b/test-suite/standalone/test-num2integral.c
index 8b69b07..af995ec 100644
--- a/test-suite/standalone/test-num2integral.c
+++ b/test-suite/standalone/test-num2integral.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2008, 2010 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,8 +25,6 @@
#include <stdio.h>
#include <assert.h>
-#if SCM_ENABLE_DISCOURAGED == 1
-
SCM out_of_range_handler (void *data, SCM key, SCM args);
SCM call_num2long_long_body (void *data);
SCM call_num2ulong_long_body (void *data);
@@ -35,37 +33,36 @@ SCM call_num2ulong_long_body (void *data);
SCM
out_of_range_handler (void *data, SCM key, SCM args)
{
- assert (scm_equal_p (key, scm_str2symbol ("out-of-range")));
+ assert (scm_equal_p (key, scm_from_locale_symbol ("out-of-range")));
return SCM_BOOL_T;
}
SCM
call_num2long_long_body (void *data)
{
- scm_num2long_long (* (SCM *) data, SCM_ARG1, "call_num2long_long_body");
+ scm_to_long_long (* (SCM *) data);
return SCM_BOOL_F;
}
SCM
call_num2ulong_long_body (void *data)
{
- scm_num2ulong_long (* (SCM *) data, SCM_ARG1, "call_num2ulong_long_body");
+ scm_to_ulong_long (* (SCM *) data);
return SCM_BOOL_F;
}
static void
test_long_long ()
{
-#if SCM_SIZEOF_LONG_LONG != 0
{
- SCM n = scm_long_long2num (SCM_I_LLONG_MIN);
- long long result = scm_num2long_long(n, 0, "main");
+ SCM n = scm_from_long_long (SCM_I_LLONG_MIN);
+ long long result = scm_to_long_long(n);
assert (result == SCM_I_LLONG_MIN);
}
/* LLONG_MIN - 1 */
{
- SCM n = scm_difference (scm_long_long2num (SCM_I_LLONG_MIN), scm_from_int
(1));
+ SCM n = scm_difference (scm_from_long_long (SCM_I_LLONG_MIN), scm_from_int
(1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -73,8 +70,8 @@ test_long_long ()
/* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */
{
- SCM n = scm_sum (scm_long_long2num (SCM_I_LLONG_MIN),
- scm_long_long2num (SCM_I_LLONG_MIN / 2));
+ SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MIN),
+ scm_from_long_long (SCM_I_LLONG_MIN / 2));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -82,7 +79,7 @@ test_long_long ()
/* SCM_I_LLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_long_long2num (SCM_I_LLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -104,18 +101,14 @@ test_long_long ()
out_of_range_handler, NULL);
assert (scm_is_true (caught));
}
-
-#endif /* SCM_SIZEOF_LONG_LONG != 0 */
}
static void
test_ulong_long ()
{
-#if SCM_SIZEOF_LONG_LONG != 0
-
{
- SCM n = scm_ulong_long2num (SCM_I_ULLONG_MAX);
- unsigned long long result = scm_num2ulong_long(n, 0, "main");
+ SCM n = scm_from_ulong_long (SCM_I_ULLONG_MAX);
+ unsigned long long result = scm_to_ulong_long(n);
assert (result == SCM_I_ULLONG_MAX);
}
@@ -129,7 +122,7 @@ test_ulong_long ()
/* SCM_I_ULLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_ulong_long2num (SCM_I_ULLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_ulong_long (SCM_I_ULLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -142,8 +135,6 @@ test_ulong_long ()
out_of_range_handler, NULL);
assert (scm_is_true (caught));
}
-
-#endif /* SCM_SIZEOF_LONG_LONG != 0 */
}
static void
@@ -159,13 +150,3 @@ main (int argc, char *argv[])
scm_boot_guile (argc, argv, tests, NULL);
return 0;
}
-
-#else /* SCM_ENABLE_DISCOURAGED == 0 */
-
-int
-main (int argc, char *argv[])
-{
- return 0;
-}
-
-#endif /* SCM_ENABLE_DISCOURAGED == 0 */
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 10fdf46..eb12360 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -23,35 +23,67 @@
(define-module (test-foreign)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
#:use-module (test-suite lib))
(with-test-prefix "null pointer"
(pass-if "zero"
- (= 0 (foreign-ref %null-pointer)))
+ (= 0 (pointer-address %null-pointer)))
- (pass-if-exception "foreign-set! %null-pointer"
- exception:null-pointer-error
- (foreign-set! %null-pointer 2))
-
- (pass-if "foreign-set! other-null-pointer"
- (let ((f (bytevector->foreign (make-bytevector 2))))
- (and (not (= 0 (foreign-ref f)))
- (begin
- (foreign-set! f 0)
- (= 0 (foreign-ref f)))
- (begin
- ;; Here changing the pointer value of F is perfectly valid.
- (foreign-set! f 777)
- (= 777 (foreign-ref f))))))
-
- (pass-if-exception "foreign->bytevector %null-pointer"
- exception:null-pointer-error
- (foreign->bytevector %null-pointer))
+ (pass-if "null pointer identity"
+ (eq? %null-pointer (make-pointer 0)))
- (pass-if-exception "foreign->bytevector other-null-pointer"
+ (pass-if "null-pointer? %null-pointer"
+ (null-pointer? %null-pointer))
+
+ (pass-if-exception "pointer->bytevector %null-pointer"
exception:null-pointer-error
- (let ((f (bytevector->foreign (make-bytevector 2))))
- (foreign-set! f 0)
- (foreign->bytevector f))))
+ (pointer->bytevector %null-pointer 7)))
+
+
+(with-test-prefix "make-pointer"
+
+ (pass-if "address preserved"
+ (= 123 (pointer-address (make-pointer 123)))))
+
+
+(with-test-prefix "pointer<->bytevector"
+
+ (pass-if "bijection"
+ (let ((bv #vu8(0 1 2 3 4 5 6 7)))
+ (equal? (pointer->bytevector (bytevector->pointer bv)
+ (bytevector-length bv))
+ bv)))
+
+ (pass-if "pointer from bits"
+ (let* ((bytes (iota (sizeof '*)))
+ (bv (u8-list->bytevector bytes)))
+ (= (pointer-address
+ (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
+ (sizeof '*))))
+ (fold-right (lambda (byte address)
+ (+ byte (* 256 address)))
+ 0
+ bytes))))
+
+ (pass-if "dereference-pointer"
+ (let* ((bytes (iota (sizeof '*)))
+ (bv (u8-list->bytevector bytes)))
+ (= (pointer-address
+ (dereference-pointer (bytevector->pointer bv)))
+ (fold-right (lambda (byte address)
+ (+ byte (* 256 address)))
+ 0
+ bytes)))))
+
+
+(with-test-prefix "structs"
+
+ (pass-if "parse-c-struct"
+ (let ((layout (list int64 uint8))
+ (data (list -300 43)))
+ (equal? (parse-c-struct (make-c-struct layout data)
+ layout)
+ data))))
diff --git a/test-suite/tests/lua-eval-2.test b/test-suite/tests/lua-eval-2.test
index 272fea4..ae15377 100644
--- a/test-suite/tests/lua-eval-2.test
+++ b/test-suite/tests/lua-eval-2.test
@@ -1,4 +1,4 @@
-;; lua-eval.test --- basic tests for builtin lua constructs -*- mode: scheme
-*-
+;; lua-eval-2.test --- basic tests for builtin lua constructs, act II -*-
mode: scheme -*-
(define-module (test-lua)
#:use-module (ice-9 format)
#:use-module (language tree-il)
@@ -85,5 +85,11 @@
(test "print \"hello world\"; return true")
;; variable arguments
- (test "function test(...) print(...) end test(1,2)")
+ #;(test "function test(...) print(...) end test(1,2)")
+
+ ;; numeric for loop
+ (test "for x = 1,2,1 do print(true) end return true")
+
+ ;; list for loop, and ipairs
+ (test "table = {1,2,3} for i,v in ipairs(table) do print(i,v) end")
))
diff --git a/test-suite/tests/lua-eval.test b/test-suite/tests/lua-eval.test
index e65b734..22a17c2 100644
--- a/test-suite/tests/lua-eval.test
+++ b/test-suite/tests/lua-eval.test
@@ -93,5 +93,6 @@
;; while
(test "while true do return true end")
(test "i=0; while i<5 do i=i+1 end return i" 5)
+ (test "while true do do break end return false end return true")
))
diff --git a/test-suite/tests/lua-scratch.test
b/test-suite/tests/lua-scratch.test
deleted file mode 100644
index b8e5da4..0000000
--- a/test-suite/tests/lua-scratch.test
+++ /dev/null
@@ -1,23 +0,0 @@
-(define-module (test-lua)
- #:use-module (ice-9 format)
- #:use-module (language tree-il)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-8)
- #:use-module (system base compile)
- #:use-module (test-suite lib)
-
- #:use-module (language lua parser)
-
- )
-
-(begin
- (define var
- "require 'io';"
- )
-
- (display (compile ((make-parser (open-input-string var)))
- #:from 'lua #:to 'value))
- (newline)
-)
-
-
diff --git a/test-suite/tests/r6rs-eval.test b/test-suite/tests/r6rs-base.test
similarity index 64%
copy from test-suite/tests/r6rs-eval.test
copy to test-suite/tests/r6rs-base.test
index 30a2e00..05d5802 100644
--- a/test-suite/tests/r6rs-eval.test
+++ b/test-suite/tests/r6rs-base.test
@@ -1,4 +1,4 @@
-;;; r6rs-eval.test --- Test suite for R6RS (rnrs eval)
+;;; r6rs-base.test --- Test suite for R6RS (rnrs base)
;; Copyright (C) 2010 Free Software Foundation, Inc.
;;
@@ -17,12 +17,17 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(define-module (test-suite test-rnrs-eval)
- :use-module ((rnrs eval) :version (6))
+(define-module (test-suite test-r6rs-base)
+ :use-module ((rnrs base) :version (6))
:use-module (test-suite lib))
-(with-test-prefix "environment"
- (pass-if "simple"
- (eqv? (eval '(eval:car (eval:cons 2 4))
- (environment '(prefix (only (rnrs base) car cons) eval:)))
- 2)))
+(with-test-prefix "vector-for-each"
+ (pass-if "vector-for-each simple"
+ (let ((sum 0))
+ (vector-for-each (lambda (x) (set! sum (+ sum x))) '#(1 2 3))
+ (eqv? sum 6))))
+
+(with-test-prefix "vector-map"
+ (pass-if "vector-map simple"
+ (equal? '#(3 2 1) (vector-map (lambda (x) (- 4 x)) '#(1 2 3)))))
+
diff --git a/test-suite/tests/r6rs-eval.test b/test-suite/tests/r6rs-lists.test
similarity index 68%
copy from test-suite/tests/r6rs-eval.test
copy to test-suite/tests/r6rs-lists.test
index 30a2e00..ba645ed 100644
--- a/test-suite/tests/r6rs-eval.test
+++ b/test-suite/tests/r6rs-lists.test
@@ -1,4 +1,4 @@
-;;; r6rs-eval.test --- Test suite for R6RS (rnrs eval)
+;;; r6rs-lists.test --- Test suite for R6RS (rnrs lists)
;; Copyright (C) 2010 Free Software Foundation, Inc.
;;
@@ -17,12 +17,16 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(define-module (test-suite test-rnrs-eval)
- :use-module ((rnrs eval) :version (6))
+(define-module (test-suite test-r6rs-lists)
+ :use-module ((rnrs lists) :version (6))
:use-module (test-suite lib))
-(with-test-prefix "environment"
- (pass-if "simple"
- (eqv? (eval '(eval:car (eval:cons 2 4))
- (environment '(prefix (only (rnrs base) car cons) eval:)))
- 2)))
+(with-test-prefix "memp"
+ (pass-if "memp simple"
+ (equal? (memp even? '(3 1 4 1 5 9 2 6 5)) '(4 1 5 9 2 6 5))))
+
+(with-test-prefix "assp"
+ (pass-if "assp simple"
+ (let ((d '((3 a) (1 b) (4 c))))
+ (equal? (assp even? d) '(4 c)))))
+
diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test
index fe85625..f4df7de 100644
--- a/test-suite/tests/vectors.test
+++ b/test-suite/tests/vectors.test
@@ -1,6 +1,6 @@
;;;; vectors.test --- test suite for Guile's vector functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2010 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
@@ -62,3 +62,82 @@
(equal? #("ab\u0100" "ab\u0100" "ab\u0100")
(make-vector 3 "ab\u0100"))))
+(with-test-prefix "vector-move-left!"
+
+ (pass-if-exception "before start" exception:out-of-range
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-left! a 3 5 b -1)))
+
+ (pass-if "beginning"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-left! a 3 5 b 0)
+ (equal? b #(4 5 30 40 50 60 70 80 90))))
+
+ (pass-if "middle"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-left! a 3 5 b 2)
+ (equal? b #(10 20 4 5 50 60 70 80 90))))
+
+ (pass-if "overlap -"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9)))
+ (vector-move-left! a 3 5 a 2)
+ (equal? a #(1 2 4 5 5 6 7 8 9))))
+
+ (pass-if "overlap +"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9)))
+ (vector-move-left! a 3 5 a 4)
+ (equal? a #(1 2 3 4 4 4 7 8 9))))
+
+ (pass-if "end"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-left! a 3 5 b 7)
+ (equal? b #(10 20 30 40 50 60 70 4 5))))
+
+ (pass-if-exception "past end" exception:out-of-range
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-left! a 3 5 b 8))))
+
+(with-test-prefix "vector-move-right!"
+
+ (pass-if-exception "before start" exception:out-of-range
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-right! a 3 5 b -1)))
+
+ (pass-if "beginning"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-right! a 3 5 b 0)
+ (equal? b #(4 5 30 40 50 60 70 80 90))))
+
+ (pass-if "middle"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-right! a 3 5 b 2)
+ (equal? b #(10 20 4 5 50 60 70 80 90))))
+
+ (pass-if "overlap -"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9)))
+ (vector-move-right! a 3 5 a 2)
+ (equal? a #(1 2 5 5 5 6 7 8 9))))
+
+ (pass-if "overlap +"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9)))
+ (vector-move-right! a 3 5 a 4)
+ (equal? a #(1 2 3 4 4 5 7 8 9))))
+
+ (pass-if "end"
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-right! a 3 5 b 7)
+ (equal? b #(10 20 30 40 50 60 70 4 5))))
+
+ (pass-if-exception "past end" exception:out-of-range
+ (let ((a (vector 1 2 3 4 5 6 7 8 9))
+ (b (vector 10 20 30 40 50 60 70 80 90)))
+ (vector-move-right! a 3 5 b 8))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-299-g57965d0,
No Itisnt <=