cscope.out
cscope.files
*.log
+gds-test.debug
+gds-test.transcript
INSTALL
*.aux
*.cp
/lib/time.h
/lib/unistd.h
/lib/unistr/.dirstamp
+/lib/arpa/inet.h
+/lib/stdio.h
+/lib/sys/stat.h
/GPATH
/GRTAGS
/GSYMS
/GTAGS
/meta/guile-tools
+/meta/guile-config
+/lib/locale.h
+/module/ice-9/eval.go.stamp
--- /dev/null
+--user ludo@gnu.org
--- /dev/null
+^lib/
+^gc-benchmarks/
+^libguile/libgettext.h
+^libguile/mkstemp.c
--- /dev/null
+^libguile/stime.c
--- /dev/null
+^gc-benchmarks/
--- /dev/null
+^libguile/
+^guile-readline/
+^gc-benchmarks/
+^emacs/
+^NEWS
+^doc/
--- /dev/null
+^module/ice-9/match.scm
--- /dev/null
+m4/version-etc.m4
--- /dev/null
+lib(guile)?/
+guile-readline/
+srfi/
Many changes throughout.
Neil Jerram:
+In the subdirectory emacs, wrote:
+ gds.el gds-scheme.el gds-server.el
+ gds-test.el gds-test.sh gds-test.stdin
+ gds-tutorial.txt gds-faq.txt
In the subdirectory ice-9, wrote:
- buffered-input.scm
+ buffered-input.scm gds-client.scm gds-server.scm
+In the subdirectory ice-9/debugging, wrote:
+ example-fns.scm ice-9-debugger-extensions.scm
+ steps.scm trace.scm traps.scm
+ trc.scm
+In the subdirectory lang/elisp, wrote:
+ base.scm example.el interface.scm
+ transform.scm variables.scm
+In the subdirectory lang/elisp/internals, wrote:
+ evaluation.scm format.scm fset.scm
+ lambda.scm load.scm null.scm
+ set.scm signal.scm time.scm
+ trace.scm
+In the subdirectory lang/elisp/primitives, wrote:
+ buffers.scm char-table.scm features.scm
+ fns.scm format.scm guile.scm
+ keymaps.scm lists.scm load.scm
+ match.scm numbers.scm pure.scm
+ read.scm signal.scm strings.scm
+ symprop.scm syntax.scm system.scm
+ time.scm
+In the subdirectory srfi, wrote:
+ srfi-34.scm
In the subdirectory doc, wrote:
deprecated.texi goops.texi scheme-ideas.texi
scheme-reading.texi
scm.texi scripts.texi script-getopt.texi
In the subdirectory doc/maint, wrote:
docstring.el
+Many other changes throughout.
Thien-Thi Nguyen:
In the top-level directory, wrote:
--- /dev/null
+# Having a separate GNUmakefile lets me `include' the dynamically
+# generated rules created via cfg.mk (package-local configuration)
+# as well as maint.mk (generic maintainer rules).
+# This makefile is used only if you run GNU Make.
+# It is necessary if you want to build targets usually of interest
+# only to the maintainer.
+
+# Copyright (C) 2001, 2003, 2006-2009 Free Software Foundation, Inc.
+
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+
+# This program 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 General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# Systems where /bin/sh is not the default shell need this. The $(shell)
+# command below won't work with e.g. stock DOS/Windows shells.
+ifeq ($(wildcard /bin/s[h]),/bin/sh)
+SHELL = /bin/sh
+else
+# will be used only with the next shell-test line, then overwritten
+# by a configured-in value
+SHELL = sh
+endif
+
+# If the user runs GNU make but has not yet run ./configure,
+# give them a diagnostic.
+_have-Makefile := $(shell test -f Makefile && echo yes)
+ifeq ($(_have-Makefile),yes)
+
+# Make tar archive easier to reproduce.
+export TAR_OPTIONS = --owner=0 --group=0 --numeric-owner
+
+# Allow the user to add to this in the Makefile.
+ALL_RECURSIVE_TARGETS =
+
+include Makefile
+
+# Some projects override e.g., _autoreconf here.
+-include $(srcdir)/cfg.mk
+include $(srcdir)/maint.mk
+
+# Allow cfg.mk to override these.
+_build-aux ?= build-aux
+_autoreconf ?= autoreconf
+
+# Ensure that $(VERSION) is up to date for dist-related targets, but not
+# for others: rerunning autoreconf and recompiling everything isn't cheap.
+_have-git-version-gen := \
+ $(shell test -f $(srcdir)/$(_build-aux)/git-version-gen && echo yes)
+ifeq ($(_have-git-version-gen)0,yes$(MAKELEVEL))
+ _is-dist-target ?= $(filter-out %clean, \
+ $(filter maintainer-% dist% alpha beta major,$(MAKECMDGOALS)))
+ _is-install-target ?= $(filter-out %check, $(filter install%,$(MAKECMDGOALS)))
+ ifneq (,$(_is-dist-target)$(_is-install-target))
+ _curr-ver := $(shell cd $(srcdir) \
+ && $(_build-aux)/git-version-gen .tarball-version)
+ ifneq ($(_curr-ver),$(VERSION))
+ ifeq ($(_curr-ver),UNKNOWN)
+ $(info WARNING: unable to verify if $(VERSION) is the correct version)
+ else
+ ifneq (,$(_is-install-target))
+ # GNU Coding Standards state that 'make install' should not cause
+ # recompilation after 'make all'. But as long as changing the version
+ # string alters config.h, the cost of having 'make all' always have an
+ # up-to-date version is prohibitive. So, as a compromise, we merely
+ # warn when installing a version string that is out of date; the user
+ # should run 'autoreconf' (or something like 'make distcheck') to
+ # fix the version, 'make all' to propagate it, then 'make install'.
+ $(info WARNING: version string $(VERSION) is out of date;)
+ $(info run '$(MAKE) _version' to fix it)
+ else
+ $(info INFO: running autoreconf for new version string: $(_curr-ver))
+ _dummy := $(shell $(MAKE) $(AM_MAKEFLAGS) _version)
+ endif
+ endif
+ endif
+ endif
+endif
+
+.PHONY: _version
+_version:
+ cd $(srcdir) && rm -rf autom4te.cache .version && $(_autoreconf)
+
+else
+
+.DEFAULT_GOAL := abort-due-to-no-makefile
+srcdir = .
+
+# The package can override .DEFAULT_GOAL to run actions like autoreconf.
+-include ./cfg.mk
+include ./maint.mk
+
+ifeq ($(.DEFAULT_GOAL),abort-due-to-no-makefile)
+$(MAKECMDGOALS): abort-due-to-no-makefile
+endif
+
+abort-due-to-no-makefile:
+ @echo There seems to be no Makefile in this directory. 1>&2
+ @echo "You must run ./configure before running \`make'." 1>&2
+ @exit 1
+
+endif
+
+# Tell version 3.79 and up of GNU make to not build goals in this
+# directory in parallel, in case someone tries to build multiple
+# targets, and one of them can cause a recursive target to be invoked.
+
+# Only set this if Automake doesn't provide it.
+AM_RECURSIVE_TARGETS ?= $(RECURSIVE_TARGETS:-recursive=) \
+ $(RECURSIVE_CLEAN_TARGETS:-recursive=) \
+ dist distcheck tags ctags
+
+ALL_RECURSIVE_TARGETS += $(AM_RECURSIVE_TARGETS)
+
+ifneq ($(word 2, $(MAKECMDGOALS)), )
+ifneq ($(filter $(ALL_RECURSIVE_TARGETS), $(MAKECMDGOALS)), )
+.NOTPARALLEL:
+endif
+endif
GUILE_MAJOR_VERSION=1
GUILE_MINOR_VERSION=9
-GUILE_MICRO_VERSION=2
+GUILE_MICRO_VERSION=5
GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}
GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION}
-# For automake.
-VERSION=${GUILE_VERSION}
-PACKAGE=guile
-
# All of the shared lib versioning info. Right now, for this to work
# properly, you'll also need to add AC_SUBST calls to the right place
# in configure.in, add the right -version-info statement to your
LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION=0
LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE=0
LIBGUILE_SRFI_SRFI_60_INTERFACE="${LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE}"
-
-LIBGUILE_I18N_MAJOR=0
-LIBGUILE_I18N_INTERFACE_CURRENT=0
-LIBGUILE_I18N_INTERFACE_REVISION=0
-LIBGUILE_I18N_INTERFACE_AGE=0
-LIBGUILE_I18N_INTERFACE="${LIBGUILE_I18N_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_I18N_INTERFACE_AGE}"
AUTOMAKE_OPTIONS = 1.10
SUBDIRS = lib meta libguile guile-readline emacs \
- srfi doc examples test-suite benchmark-suite lang am \
+ srfi doc examples test-suite benchmark-suite am \
module testsuite
include_HEADERS = libguile.h
DISTCLEANFILES = check-guile.log
+DISTCHECK_CONFIGURE_FLAGS = --enable-error-on-warning
+
dist-hook: gen-ChangeLog
clean-local:
(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.3 (since the 1.9.2 prerelease):
+Changes in 1.9.5 (since the 1.9.4 prerelease):
-** Removed deprecated uniform array procedures: scm_make_uve,
- scm_array_prototype, scm_list_to_uniform_array,
- scm_dimensions_to_uniform_array, scm_make_ra, scm_shap2ra, scm_cvref,
- scm_ra_set_contp, scm_aind, scm_raprin1
+** Compiled procedures may now have more than one arity.
-These functions have been deprecated since early 2005.
+This can be the case, for example, in case-lambda procedures. The
+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.
-** scm_array_p has one argument, not two
+** `case-lambda' is now available in the default environment.
-Use of the second argument produced a deprecation warning, so it is
-unlikely that any code out there actually used this functionality.
+The binding in the default environment is equivalent to the one from the
+`(srfi srfi-16)' module. Use the srfi-16 module explicitly if you wish
+to maintain compatibility with Guile 1.8 and earlier.
-** Removed deprecated uniform array procedures:
- dimensions->uniform-array, list->uniform-array, array-prototype
+** VM calling convention change: callee-parsed arguments
-Instead, use make-typed-array, list->typed-array, or array-type,
-respectively.
+As an internal implementation detail, compiled procedures are now
+responsible for parsing their own arguments, which they receive on the
+stack.
+
+** VM support for multiple-arity dispatch
+
+Calls to procedures with multiple arities, for example those made be
+`case-lambda', now dispatch via special opcodes, without the need to
+cons a rest list.
+
+** Intermediate language support for multiple-arity procedures.
+
+In the intermediate language, tree-il, all procedures may have one or
+more arities. This allows all Guile languages to have multiple arities.
+It is, however, an incompatible change, and anyone maintaining a
+compiler out-of-tree would be advised to get it into Guile soon :)
+
+** `lambda*' and `define*' are now available in the default environment
+
+As with `case-lambda', `(ice-9 optargs)' continues to be supported, for
+compatibility purposes. No semantic change has been made (we hope).
+Optional and keyword arguments now dispatch via special VM operations,
+without the need to cons rest arguments, making them very fast.
+
+** Better support for Lisp `nil'.
+
+The bit representation of `nil' has been tweaked so that it is now very
+efficient to check e.g. if a value is equal to Scheme's end-of-list or
+Lisp's nil. Additionally there are a heap of new, specific predicates
+like scm_is_null_or_nil. Probably in the future we will #define
+scm_is_null to scm_is_null_or_nil.
+
+** No future.
+
+Actually the future is still in the state that it was, is, and ever
+shall be, Amen, except that `futures.c' and `futures.h' are no longer a
+part of it. These files were experimental, never compiled, and would be
+better implemented in Scheme anyway. In the future, that is.
+
+** Support for static allocation of strings, symbols, and subrs.
+
+Calls to snarfing CPP macros like SCM_DEFINE macro will now allocate
+much of their associated data as static variables, reducing Guile's
+memory footprint.
+
+** Inline vector allocation
+
+Instead of having vectors point out into the heap for their data, their
+data is now allocated inline to the vector object itself. The same is
+true for bytevectors, by default, though there is an indirection
+available which should allow for making a bytevector from an existing
+memory region.
+
+** New syntax: include-from-path.
+
+`include-from-path' is like `include', except it looks for its file in
+the load path. It can be used to compile other files into a file.
+
+** New syntax: quasisyntax.
+
+`quasisyntax' is to `syntax' as `quasiquote' is to `quote'. See the R6RS
+documentation for more information. Thanks to Andre van Tonder for the
+implementation.
+
+** Cleanups to Guile's primitive object system.
+
+There were a number of pieces in `objects.[ch]' that tried to be a
+minimal object system, but were never documented, and were quickly
+obseleted by GOOPS' merge into Guile proper. So `scm_make_class_object',
+`scm_make_subclass_object', `scm_metaclass_standard', and like symbols
+from objects.h are no more. In the very unlikely case in which these
+were useful to you, we urge you to contact guile-devel.
+
+** GOOPS cleanups.
+
+GOOPS had a number of concepts that were relevant to the days of Tcl,
+but not any more: operators and entities, mainly. These objects were
+never documented, and it is unlikely that they were ever used. Operators
+were a kind of generic specific to the Tcl support. Entities were
+applicable structures, but were unusable; entities will come back in the
+next alpha release, but with a less stupid name.
+
+** Faster bit operations.
+
+The bit-twiddling operations `ash', `logand', `logior', and `logxor' now
+have dedicated bytecodes. Guile is not just for symbolic computation,
+it's for number crunching too.
+
+** `inet-ntop' and `inet-pton' are always available.
+
+Guile now use a portable implementation of `inet_pton'/`inet_ntop', so
+there is no more need to use `inet-aton'/`inet-ntoa'. The latter
+functions are deprecated.
+
+** R6RS block comment support
+
+Guile now supports R6RS nested block comments. The start of a comment is
+marked with `#|', and the end with `|#'.
+
+** `guile-2' cond-expand feature
+
+To test if your code is running under Guile 2.0 (or its alpha releases),
+test for the `guile-2' cond-expand feature. Like this:
+
+ (cond-expand (guile-2 (eval-when (compile)
+ ;; This must be evaluated at compile time.
+ (fluid-set! current-reader my-reader)))
+ (guile
+ ;; Earlier versions of Guile do not have a
+ ;; separate compilation phase.
+ (fluid-set! current-reader my-reader)))
+
+** ABI harmonization
+
+`scm_search_path' now has the signature it did in 1.8, reverting an
+incompatible change made in 1.9.0.
+
+** Compile-time warnings: -Warity-mismatch
+
+Guile can warn when you pass the wrong number of arguments to a
+procedure. Pass the -Warity-mismatch on the `guile-tools compile'
+command line, or add `#:warnings '(arity-mismatch)' to your `compile'
+or `compile-file' invocation.
+
+** Guile is now built without `-Werror' by default
+
+Use the `--enable-error-on-warning' configure option to enable it.
** And of course, the usual collection of bugfixes
Interested users should see the ChangeLog for more information.
+\f
Changes in 1.9.x (since the 1.8.x series):
* New modules (see the manual for details)
Pass the `--help' command-line option to these commands for more
information.
+** Guile now adds its install prefix to the LTDL_LIBRARY_PATH
+
+Users may now install Guile to nonstandard prefixes and just run
+`/path/to/bin/guile', instead of also having to set LTDL_LIBRARY_PATH to
+include `/path/to/lib'.
+
+** Guile's Emacs integration is now more keyboard-friendly
+
+Backtraces may now be disclosed with the keyboard in addition to the
+mouse.
+
* Changes to Scheme functions and syntax
** Procedure removed: `the-environment'
not compiled. This bug will be fixed before 2.0. FIXME 2.0: Should say
something here about module-transformer called for compile.
+** Files loaded with `load' will now be compiled automatically.
+
+As with files loaded via `primitive-load-path', `load' will also compile
+its target if autocompilation is enabled, and a fresh compiled file is
+not found.
+
+There are two points of difference to note, however. First, `load' does
+not search `GUILE_LOAD_COMPILED_PATH' for the file; it only looks in the
+autocompilation directory, normally a subdirectory of ~/.cache/guile.
+
+Secondly, autocompilation also applies to files loaded via the -l
+command-line argument -- so the user may experience a slight slowdown
+the first time they run a Guile script, as the script is autocompiled.
+
** New POSIX procedures: `getrlimit' and `setrlimit'
Note however that the interface of these functions is likely to change
to guile-devel@gnu.org (subscription required) or bug-guile@gnu.org (no
subscription required).
+** `case-lambda' is now available in the default environment.
+
+The binding in the default environment is equivalent to the one from the
+`(srfi srfi-16)' module. Use the srfi-16 module explicitly if you wish
+to maintain compatibility with Guile 1.8 and earlier.
+
+** `lambda*' and `define*' are now available in the default environment
+
+As with `case-lambda', `(ice-9 optargs)' continues to be supported, for
+compatibility purposes. No semantic change has been made (we hope).
+Optional and keyword arguments now dispatch via special VM operations,
+without the need to cons rest arguments, making them very fast.
+
+** New syntax: include-from-path.
+
+`include-from-path' is like `include', except it looks for its file in
+the load path. It can be used to compile other files into a file.
+
+** New syntax: quasisyntax.
+
+`quasisyntax' is to `syntax' as `quasiquote' is to `quote'. See the R6RS
+documentation for more information. Thanks to Andre van Tonder for the
+implementation.
+
** Unicode characters
Unicode characters may be entered in octal format via e.g. `#\454', or
encoding, one byte per character, or in UTF-32, with four bytes per
character. Strings manage their own allocation, switching if needed.
-Currently no locale conversion is performed. Extended characters may be
-written in a string using the hexadecimal escapes `\xXX', `\uXXXX', or
-`\UXXXXXX', for 8-bit, 16-bit, or 24-bit codepoints, respectively.
+Extended characters may be written in a literal string using the
+hexadecimal escapes `\xXX', `\uXXXX', or `\UXXXXXX', for 8-bit, 16-bit,
+or 24-bit codepoints, respectively, or entered directly in the native
+encoding of the port on which the string is read.
+
+** Unicode symbols
+
+One may now use U+03BB (GREEK SMALL LETTER LAMBDA) as an identifier.
+
+** Support for non-ASCII source code files
+
+The default reader now handles source code files for some of the
+non-ASCII character encodings, such as UTF-8. A non-ASCII source file
+should have an encoding declaration near the top of the file. Also,
+there is a new function, `file-encoding', that scans a port for a coding
+declaration. See the section of the manual entitled, "Character Encoding
+of Source Files".
+
+The pre-1.9.3 reader handled 8-bit clean but otherwise unspecified source
+code. This use is now discouraged.
+
+** Support for locale transcoding when reading from and writing to ports
+
+Ports now have an associated character encoding, and port read and write
+operations do conversion to and from locales automatically. Ports also
+have an associated strategy for how to deal with locale conversion
+failures.
+
+See the documentation in the manual for the four new support functions,
+`set-port-encoding!', `port-encoding', `set-port-conversion-strategy!',
+and `port-conversion-strategy'.
+
+** String and SRFI-13 functions can operate on Unicode strings
+
+** Unicode support for SRFI-14 character sets
+
+The default character sets are no longer locale dependent and contain
+characters from the whole Unicode range. There is a new predefined
+character set, `char-set:designated', which contains all assigned
+Unicode characters. There is a new debugging function, `%char-set-dump'.
+
+** Character functions operate on Unicode characters
+
+`char-upcase' and `char-downcase' use default Unicode casing rules.
+Character comparisons such as `char<?' and `char-ci<?' now sort based on
+Unicode code points.
** Global variables `scm_charnames' and `scm_charnums' are removed
processing. It appeared that full EBCDIC support was never completed
and was unmaintained.
+** Compile-time warnings: -Wunbound-variable, -Warity-mismatch.
+
+Guile can warn about potentially unbound free variables. Pass the
+-Wunbound-variable on the `guile-tools compile' command line, or add
+`#:warnings '(unbound-variable)' to your `compile' or `compile-file'
+invocation.
+
+Guile can also warn when you pass the wrong number of arguments to a
+procedure, with -Warity-mismatch, or `arity-mismatch' in the
+`#:warnings' as above.
+
** New macro type: syncase-macro
XXX Need to decide whether to document this for 2.0, probably should:
See `cancel-thread', `set-thread-cleanup!', and `thread-cleanup'.
+** GOOPS cleanups.
+
+GOOPS had a number of concepts that were relevant to the days of Tcl,
+but not any more: operators and entities, mainly. These objects were
+never documented, and it is unlikely that they were ever used. Operators
+were a kind of generic specific to the Tcl support. Entities were
+applicable structures, but were unusable; entities will come back in the
+next alpha release, but with a less stupid name.
+
+** `inet-ntop' and `inet-pton' are always available.
+
+Guile now use a portable implementation of `inet_pton'/`inet_ntop', so
+there is no more need to use `inet-aton'/`inet-ntoa'. The latter
+functions are deprecated.
+
+** R6RS block comment support
+
+Guile now supports R6RS nested block comments. The start of a comment is
+marked with `#|', and the end with `|#'.
+
+** `guile-2' cond-expand feature
+
+To test if your code is running under Guile 2.0 (or its alpha releases),
+test for the `guile-2' cond-expand feature. Like this:
+
+ (cond-expand (guile-2 (eval-when (compile)
+ ;; This must be evaluated at compile time.
+ (fluid-set! current-reader my-reader)))
+ (guile
+ ;; Earlier versions of Guile do not have a
+ ;; separate compilation phase.
+ (fluid-set! current-reader my-reader)))
+
** Fix bad interaction between `false-if-exception' and stack-call.
Exceptions thrown by `false-if-exception' were erronously causing the
As syntax-case is available by default, importing `(ice-9 syncase)' has
no effect, and will trigger a deprecation warning.
+** New readline history functions
+
+The (ice-9 readline) module now provides add-history, read-history,
+write-history and clear-history, which wrap the corresponding GNU
+History library functions.
+
** Removed deprecated uniform array procedures:
dimensions->uniform-array, list->uniform-array, array-prototype
Instead, use make-typed-array, list->typed-array, or array-type,
respectively.
+** Last but not least, the `λ' macro can be used in lieu of `lambda'
+
* Changes to the C interface
+** Guile now uses libgc, the Boehm-Demers-Weiser garbage collector
+
+The semantics of `scm_gc_malloc ()' have been changed, in a
+backward-compatible way. A new allocation routine,
+`scm_gc_malloc_pointerless ()', was added.
+
+Libgc is a conservative GC, which we hope will make interaction with C
+code easier and less error-prone.
+
** The GH interface (deprecated in version 1.6, 2001) was removed.
** Internal `scm_i_' functions now have "hidden" linkage with GCC/ELF
This procedure corresponds to Scheme's `module-public-interface'.
+** Inline vector allocation
+
+Instead of having vectors point out into the heap for their data, their
+data is now allocated inline to the vector object itself. The same is
+true for bytevectors, by default, though there is an indirection
+available which should allow for making a bytevector from an existing
+memory region.
+
+** Removal of Guile's primitive object system.
+
+There were a number of pieces in `objects.[ch]' that tried to be a
+minimal object system, but were never documented, and were quickly
+obseleted by GOOPS' merge into Guile proper. So `scm_make_class_object',
+`scm_make_subclass_object', `scm_metaclass_standard', and like symbols
+from objects.h are no more. In the very unlikely case in which these
+were useful to you, we urge you to contact guile-devel.
+
+** No future.
+
+Actually the future is still in the state that it was, is, and ever
+shall be, Amen, except that `futures.c' and `futures.h' are no longer a
+part of it. These files were experimental, never compiled, and would be
+better implemented in Scheme anyway. In the future, that is.
+
+** Support for static allocation of strings, symbols, and subrs.
+
+Calls to snarfing CPP macros like SCM_DEFINE macro will now allocate
+much of their associated data as static variables, reducing Guile's
+memory footprint.
+
** `scm_stat' has an additional argument, `exception_on_error'
** `scm_primitive_load_path' has an additional argument `exception_on_not_found'
These functions have been deprecated since early 2005.
-** scm_array_p has one argument, not two
-
-Use of the second argument produced a deprecation warning, so it is
-unlikely that any code out there actually used this functionality.
-
* Changes to the distribution
** Guile's license is now LGPLv3+
later (at the discretion of each person that chooses to redistribute
part of Guile).
+** GOOPS documentation folded into Guile reference manual
+
+GOOPS, Guile's object system, used to be documented in separate manuals.
+This content is now included in Guile's manual directly.
+
** `guile-config' will be deprecated in favor of `pkg-config'
`guile-config' has been rewritten to get its information from
If $(libdir) is /usr/lib, for example, Guile will install its .go files
to /usr/lib/guile/1.9/ccache. These files are architecture-specific.
-** New dependency: GNU libunistring.
+** Dynamically loadable extensions may be placed in a Guile-specific path
+
+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
+guile-2.0' to get the location of the extensions directory.
+
+** New dependency: libgc
+
+See http://www.hpl.hp.com/personal/Hans_Boehm/gc/, for more information.
+
+** New dependency: GNU libunistring
See http://www.gnu.org/software/libunistring/, for more information. Our
-unicode support uses routines from libunistring.
+Unicode support uses routines from libunistring.
\f
** Fix possible buffer overruns when parsing numbers
** Avoid clash with system setjmp/longjmp on IA64
+** Fix `wrong type arg' exceptions with IPv6 addresses
\f
Changes in 1.8.7 (since 1.8.6)
- libintl
- libltdl
- libunistring
+- libgc
It will also use the libreadline library if it is available. For each
of these there is a corresponding --with-XXX-prefix option that you
can use when invoking ./configure, if you have these libraries
- GNU MP, at least version 4.1
GNU MP is used for bignum arithmetic. It is available from
- http://swox.com/gmp
+ http://gmplib.org/ .
- - libltdl from libtool, at least from libtool version 1.5.6
+ - libltdl from GNU Libtool, at least version 1.5.6
libltdl is used for loading extensions at run-time. It is
- available from http://www.gnu.org/software/libtool/
+ available from http://www.gnu.org/software/libtool/ .
- GNU libunistring
`utf*->string' procedures. It is available from
http://www.gnu.org/software/libunistring/ .
+ - libgc, at least version 7.0
+
+ libgc (aka. the Boehm-Demers-Weiser garbage collector) is the
+ conservative garbage collector used by Guile. It is available
+ from http://www.hpl.hp.com/personal/Hans_Boehm/gc/ .
+
Special Instructions For Some Systems =====================================
Rob Browning
Adrian Bunk
Michael Carmack
+ R Clayton
Stephen Compall
Brian Crowder
Christopher Cramer
Roland Haeder
Sven Hartrumpf
Eric Hanchrow
+ Judy Hawkins
Sam Hocevar
Patrick Horgan
Ales Hvezda
Antoine Mathys
Dan McMahill
Roger Mc Murtrie
+ Scott McPeak
Tim Mooney
Han-Wen Nienhuys
Jan Nieuwenhuizen
Peter O'Gorman
Pieter Pareit
Jack Pavlovsky
+ Derek Peschel
Arno Peters
Ron Peterson
David Pirotte
Werner Scheinast
Bill Schottstaedt
Frank Schwidom
+ John Steele Scott
Thiemo Seufer
Scott Shedden
Alex Shinn
Andreas Vögele
Michael Talbot-Wilson
Michael Tuexen
+ Thomas Wawrzinek
Mark H. Weaver
Jon Wilson
Andy Wingo
]
)
if test "$guile_cv_header_libc_with_unistd" = yes; then
- AC_DEFINE(LIBC_H_WITH_UNISTD_H, 1,
+ AC_DEFINE([LIBC_H_WITH_UNISTD_H], 1,
[Define this if we should include <libc.h> when we've already
included <unistd.h>. On some systems, they conflict, and libc.h
should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in
done
AC_MSG_RESULT($attr_name)
if test "$attr_name" != PTHREAD_CREATE_JOINABLE; then
- AC_DEFINE_UNQUOTED(PTHREAD_CREATE_JOINABLE, $attr_name,
+ AC_DEFINE_UNQUOTED([PTHREAD_CREATE_JOINABLE], $attr_name,
[Define to necessary symbol if this constant
uses a non-standard name on your system.])
fi
# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND:
if test x"$acx_pthread_ok" = xyes; then
- ifelse([$1],,AC_DEFINE(HAVE_PTHREAD,1,[Define if you have POSIX threads libraries and header files.]),[$1])
+ ifelse([$1],,AC_DEFINE([HAVE_PTHREAD],1,[Define if you have POSIX threads libraries and header files.]),[$1])
:
else
acx_pthread_ok=no
AC_LANG_RESTORE
])dnl ACX_PTHREAD
+dnl GUILE_GNU_LD_RELRO
+dnl
+dnl Check whether GNU ld's read-only relocations (the `PT_GNU_RELRO'
+dnl ELF segment header) are supported. This allows things like
+dnl statically allocated cells (1) to eventually be remapped read-only
+dnl by the loader, and (2) to be identified as pointerless by the
+dnl garbage collector. Substitute `GNU_LD_FLAGS' with the relevant
+dnl flags.
+AC_DEFUN([GUILE_GNU_LD_RELRO], [
+ AC_MSG_CHECKING([whether the linker understands `-z relro'])
+
+ GNU_LD_FLAGS="-Wl,-z -Wl,relro"
+
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS $GNU_LD_FLAGS"
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])],
+ [AC_MSG_RESULT([yes])],
+ [AC_MSG_RESULT([no])
+ GNU_LD_FLAGS=""])
+ LDFLAGS="$save_LDFLAGS"
+
+ AC_SUBST([GNU_LD_FLAGS])
+])
+
+dnl GUILE_THREAD_LOCAL_STORAGE
+dnl
+dnl Check for compiler thread-local storage (TLS) support.
+AC_DEFUN([GUILE_THREAD_LOCAL_STORAGE], [
+ AC_CACHE_CHECK([whether the `__thread' storage class is available],
+ [ac_cv_have_thread_storage_class],
+ [dnl On some systems, e.g., NetBSD 5.0 with GCC 4.1, `__thread' is
+ dnl properly compiled but fails to link due to the lack of TLS
+ dnl support in the C library. Thus we try to link, not just
+ dnl compile. Unfortunately, this test is not enough, so we
+ dnl explicitly check for known-broken systems. See
+ dnl http://lists.gnu.org/archive/html/guile-devel/2009-10/msg00138.html
+ dnl for details.
+ case "x$enable_shared--$host" in
+ xyes--*netbsd[0-5].[0-9].)
+ ac_cv_have_thread_storage_class="no"
+ ;;
+ *)
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([__thread int tls_integer;],
+ [tls_integer = 123;])],
+ [ac_cv_have_thread_storage_class="yes"],
+ [ac_cv_have_thread_storage_class="no"])
+ ;;
+ esac])
+
+ if test "x$ac_cv_have_thread_storage_class" = "xyes"; then
+ SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS=1
+ else
+ SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS=0
+ fi
+
+ AC_SUBST([SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS])
+])
+
dnl GUILE_READLINE
dnl
dnl Check all the things needed by `guile-readline', the Readline
# -*- makefile -*-
GOBJECTS = $(SOURCES:%.scm=%.go)
+GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch
+
moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
ccachedir = $(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath)
SUFFIXES = .scm .go
.scm.go:
- GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guile-tools compile -o "$@" "$<"
+ GUILE_AUTO_COMPILE=0 \
+ $(top_builddir)/meta/uninstalled-env \
+ guile-tools compile $(GUILE_WARNINGS) -o "$@" "$<"
echo ""
automake --version
echo ""
-libtool --version
+if test "`uname -s`" = Darwin; then
+ glibtool --version
+else
+ libtool --version
+fi
echo ""
-${M4:-/usr/bin/m4} --version
+${M4:-m4} --version
echo ""
######################################################################
#! /bin/sh
# Usage: benchmark-guile [-i GUILE-INTERPRETER] [GUILE-BENCHMARK-ARGS]
-# If `-i GUILE-INTERPRETER' is omitted, use ${top_builddir}/pre-inst-guile.
+# If `-i GUILE-INTERPRETER' is omitted, use ${top_builddir}/meta/guile.
# See ${top_srcdir}/benchmark-suite/guile-benchmark for documentation on GUILE-BENCHMARK-ARGS.
#
# Example invocations:
shift
shift
else
- guile=${top_builddir}/pre-inst-guile
+ guile=${top_builddir}/meta/guile
fi
GUILE_LOAD_PATH=$BENCHMARK_SUITE_DIR
SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/bytevectors.bm \
- benchmarks/continuations.bm \
+ benchmarks/continuations.bm \
benchmarks/if.bm \
benchmarks/logand.bm \
benchmarks/read.bm \
+
+(define-module (benchmarks 0-reference)
+ :use-module (benchmark-suite lib))
+
(benchmark "reference benchmark for iteration counts" 330000
#t)
-;;; -*- mode: scheme; coding: latin-1; -*-
+;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
;;; R6RS Byte Vectors.
;;;
;;; Copyright 2009 Ludovic Courtès <ludo@gnu.org>
-;;; -*- mode: scheme; coding: latin-1; -*-
+;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
;;; chars.bm
;;;
;;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+(define-module (benchmarks continuations)
+ :use-module (benchmark-suite lib))
+
(define (callee continuation)
(continuation #t))
-(benchmark "call/cc" 300
+(benchmark "call/cc" 12000
(call-with-current-continuation callee))
+
+(define-module (benchmarks if)
+ :use-module (benchmark-suite lib))
+
(with-benchmark-prefix "if-<expr>-then-else"
(benchmark "executing then" 330000
+
+(define-module (benchmarks logand)
+ :use-module (benchmark-suite lib))
+
(define bignum (1- (expt 2 128)))
(let* ((i 0))
(benchmark "_IONBF" 5 ;; this one is very slow
(exercise-read (list _IONBF)))
- (benchmark "_IOLBF" 100
+ (benchmark "_IOLBF" 10
(exercise-read (list _IOLBF)))
- (benchmark "_IOFBF 4096" 100
+ (benchmark "_IOFBF 4096" 10
(exercise-read (list _IOFBF 4096)))
- (benchmark "_IOFBF 8192" 100
+ (benchmark "_IOFBF 8192" 10
(exercise-read (list _IOFBF 8192)))
- (benchmark "_IOFBF 16384" 100
+ (benchmark "_IOFBF 16384" 10
(exercise-read (list _IOFBF 16384))))
-;;; -*- mode: scheme; coding: latin-1; -*-
+;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
;;; srfi-13.bm
;;;
;;; Copyright (C) 2009 Free Software Foundation, Inc.
(string-ref long-string k)
(loop (+ k 1))))))
- (benchmark "copy" 1100
+ (benchmark "copy" 20000
(string-copy short-string)
(string-copy medium-string)
(string-copy long-string)
(substring/copy medium-string 10 20)
(substring/copy long-string 100 200))
- (benchmark "pad" 6800
+ (benchmark "pad" 34000
(string-pad short-string 100)
(string-pad medium-string 100)
(string-pad long-string 100))
\f
(with-benchmark-prefix "uniform-vector-read!"
- (benchmark "uniform-vector-write" 500
+ (benchmark "uniform-vector-write" 4000
(let ((output (open-output-file file-name)))
(uniform-vector-write buf output)
(close output)))
- (benchmark "uniform-vector-read!" 500
+ (benchmark "uniform-vector-read!" 20000
(let ((input (open-input-file file-name)))
(setvbuf input _IONBF)
(uniform-vector-read! buf input)
;;; A short form for benchmarks.
(defmacro benchmark (name iterations body . rest)
- `(,run-benchmark ,name ,iterations (lambda () ,body ,@rest)))
+ `(run-benchmark ,name ,iterations (lambda () ,body ,@rest)))
\f
;;;; BENCHMARK NAMES
--- /dev/null
+Benchmarking /home/neil/SW/Guile/git/meta/guile ...
+with GUILE_LOAD_PATH=/home/neil/SW/Guile/git/benchmark-suite
+;; running guile version 1.9.3
+;; calibrating the benchmarking framework...
+;; framework time per iteration: 5.7220458984375e-7
+("0-reference.bm: reference benchmark for iteration counts" 330000 user 0.2 benchmark 0.0111724853515625 bench/interp 0.0111724853515625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u8-ref" 1000000 user 0.73 benchmark 0.15779541015625 bench/interp 0.15779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u16-ref (foreign)" 1000000 user 0.82 benchmark 0.24779541015625 bench/interp 0.24779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u16-ref (native)" 1000000 user 0.78 benchmark 0.20779541015625 bench/interp 0.20779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u16-native-ref" 1000000 user 0.72 benchmark 0.14779541015625 bench/interp 0.14779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u32-ref (foreign)" 1000000 user 1.61 benchmark 1.03779541015625 bench/interp 1.03779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u32-ref (native)" 1000000 user 0.8 benchmark 0.22779541015625 bench/interp 0.22779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u32-native-ref" 1000000 user 0.74 benchmark 0.16779541015625 bench/interp 0.16779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u64-ref (foreign)" 1000000 user 1.86 benchmark 1.28779541015625 bench/interp 1.28779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u64-ref (native)" 1000000 user 0.81 benchmark 0.23779541015625 bench/interp 0.23779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u64-native-ref" 1000000 user 0.73 benchmark 0.15779541015625 bench/interp 0.15779541015625 gc 0.0)
+("bytevectors.bm: lists: bytevector->u8-list" 2000 user 9.87 benchmark 9.86885559082031 bench/interp 9.86885559082031 gc 0.0)
+("bytevectors.bm: lists: bytevector->uint-list 16-bit" 2000 user 4.48 benchmark 4.47885559082031 bench/interp 4.47885559082031 gc 0.0)
+("bytevectors.bm: lists: bytevector->uint-list 64-bit" 2000 user 3.75 benchmark 3.74885559082031 bench/interp 3.74885559082031 gc 0.0)
+("bytevectors.bm: SRFI-4: u8vector-ref" 1000000 user 1.88 benchmark 1.30779541015625 bench/interp 1.30779541015625 gc 0.0)
+("bytevectors.bm: SRFI-4: u16vector-ref" 1000000 user 1.9 benchmark 1.32779541015625 bench/interp 1.32779541015625 gc 0.0)
+("bytevectors.bm: SRFI-4: u32vector-ref" 1000000 user 1.88 benchmark 1.30779541015625 bench/interp 1.30779541015625 gc 0.0)
+("bytevectors.bm: SRFI-4: u64vector-ref" 1000000 user 1.98 benchmark 1.40779541015625 bench/interp 1.40779541015625 gc 0.0)
+("chars.bm: chars: char" 1000000 user 0.63 benchmark 0.05779541015625 bench/interp 0.05779541015625 gc 0.0)
+("chars.bm: chars: octal" 1000000 user 0.64 benchmark 0.06779541015625 bench/interp 0.06779541015625 gc 0.0)
+("chars.bm: chars: char? eq" 1000000 user 1.19 benchmark 0.61779541015625 bench/interp 0.61779541015625 gc 0.0)
+("chars.bm: chars: char=?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0)
+("chars.bm: chars: char<?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0)
+("chars.bm: chars: char-ci=?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0)
+("chars.bm: chars: char-ci<? " 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0)
+("chars.bm: chars: char->integer" 1000000 user 1.2 benchmark 0.62779541015625 bench/interp 0.62779541015625 gc 0.0)
+("chars.bm: chars: char-alphabetic?" 1000000 user 1.36 benchmark 0.78779541015625 bench/interp 0.78779541015625 gc 0.0)
+("chars.bm: chars: char-numeric?" 1000000 user 1.36 benchmark 0.78779541015625 bench/interp 0.78779541015625 gc 0.0)
+("continuations.bm: call/cc" 300 user 0.03 benchmark 0.0298283386230469 bench/interp 0.0298283386230469 gc 0.0)
+("if.bm: if-<expr>-then-else: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<expr>-then-else: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<expr>-then: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<expr>-then: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<iloc>-then-else: executing then" 330000 user 0.25 benchmark 0.0611724853515625 bench/interp 0.0611724853515625 gc 0.0)
+("if.bm: if-<iloc>-then-else: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<iloc>-then: executing then" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<iloc>-then: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<bool>-then-else: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<bool>-then-else: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<bool>-then: executing then" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<bool>-then: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("logand.bm: bignum" 130000 user 0.48 benchmark 0.405613403320312 bench/interp 0.405613403320312 gc 0.0)
+("read.bm: read: _IONBF" 5 user 12.71 benchmark 12.7099971389771 bench/interp 12.7099971389771 gc 0.0)
+("read.bm: read: _IOLBF" 10 user 20.32 benchmark 20.3199942779541 bench/interp 20.3199942779541 gc 0.0)
+("read.bm: read: _IOFBF 4096" 10 user 20.34 benchmark 20.3399942779541 bench/interp 20.3399942779541 gc 0.0)
+("read.bm: read: _IOFBF 8192" 10 user 20.36 benchmark 20.3599942779541 bench/interp 20.3599942779541 gc 0.0)
+("read.bm: read: _IOFBF 16384" 10 user 20.34 benchmark 20.3399942779541 bench/interp 20.3399942779541 gc 0.0)
+("srfi-13.bm: strings: predicates: string?" 1190000 user 2.98 benchmark 2.29907653808594 bench/interp 2.29907653808594 gc 0.0)
+("srfi-13.bm: strings: predicates: null?" 969000 user 2.56 benchmark 2.00553375244141 bench/interp 2.00553375244141 gc 0.0)
+("srfi-13.bm: strings: predicates: any" 94000 user 1.89 benchmark 1.83621276855469 bench/interp 1.83621276855469 gc 0.0)
+("srfi-13.bm: strings: predicates: every" 94000 user 1.53 benchmark 1.47621276855469 bench/interp 1.47621276855469 gc 0.0)
+("srfi-13.bm: strings: constructors: string" 5000 user 2.02 benchmark 2.01713897705078 bench/interp 2.01713897705078 gc 0.0)
+("srfi-13.bm: strings: constructors: list->" 4500 user 0.3 benchmark 0.297425079345703 bench/interp 0.297425079345703 gc 0.0)
+("srfi-13.bm: strings: constructors: reverse-list->" 5000 user 0.58 benchmark 0.577138977050781 bench/interp 0.577138977050781 gc 0.0)
+("srfi-13.bm: strings: constructors: make" 22000 user 0.52 benchmark 0.507411499023438 bench/interp 0.507411499023438 gc 0.0)
+("srfi-13.bm: strings: constructors: tabulate" 17000 user 0.57 benchmark 0.560272521972656 bench/interp 0.560272521972656 gc 0.0)
+("srfi-13.bm: strings: constructors: join" 5500 user 0.46 benchmark 0.456852874755859 bench/interp 0.456852874755859 gc 0.0)
+("srfi-13.bm: strings: list/string: ->list" 7300 user 2.36 benchmark 2.35582290649414 bench/interp 2.35582290649414 gc 0.0)
+("srfi-13.bm: strings: list/string: split" 60000 user 1.87 benchmark 1.83566772460938 bench/interp 1.83566772460938 gc 0.0)
+("srfi-13.bm: strings: selection: ref" 660 user 1.5 benchmark 1.4996223449707 bench/interp 1.4996223449707 gc 0.0)
+("srfi-13.bm: strings: selection: copy" 1100 user 0.04 benchmark 0.0393705749511719 bench/interp 0.0393705749511719 gc 0.0)
+("srfi-13.bm: strings: selection: pad" 6800 user 0.17 benchmark 0.166109008789063 bench/interp 0.166109008789063 gc 0.0)
+("srfi-13.bm: strings: selection: trim trim-right trim-both" 60000 user 2.67 benchmark 2.63566772460937 bench/interp 2.63566772460937 gc 0.0)
+("srfi-13.bm: strings: modification: set!" 3000 user 1.42 benchmark 1.41828338623047 bench/interp 1.41828338623047 gc 0.0)
+("srfi-13.bm: strings: modification: sub-move!" 230000 user 1.88 benchmark 1.74839294433594 bench/interp 1.74839294433594 gc 0.0)
+("srfi-13.bm: strings: modification: fill!" 230000 user 2.31 benchmark 2.17839294433594 bench/interp 2.17839294433594 gc 0.0)
+("srfi-13.bm: strings: modification: comparison: compare compare-ci" 140000 user 1.93 benchmark 1.84989135742187 bench/interp 1.84989135742187 gc 0.0)
+("srfi-13.bm: strings: modification: comparison: hash hash-ci" 1000 user 0.27 benchmark 0.269427795410156 bench/interp 0.269427795410156 gc 0.0)
+("srfi-13.bm: strings: searching: prefix-length suffix-length" 270 user 0.2 benchmark 0.199845504760742 bench/interp 0.199845504760742 gc 0.0)
+("srfi-13.bm: strings: searching: prefix? suffix?" 270 user 0.2 benchmark 0.199845504760742 bench/interp 0.199845504760742 gc 0.0)
+("srfi-13.bm: strings: searching: index index-right rindex" 100000 user 3.48 benchmark 3.42277954101562 bench/interp 3.42277954101562 gc 0.0)
+("srfi-13.bm: strings: searching: skip skip-right?" 100000 user 2.14 benchmark 2.08277954101563 bench/interp 2.08277954101563 gc 0.0)
+("srfi-13.bm: strings: searching: count" 10000 user 9.35 benchmark 9.34427795410156 bench/interp 9.34427795410156 gc 0.0)
+("srfi-13.bm: strings: searching: contains contains-ci" 34000 user 2.29 benchmark 2.27054504394531 bench/interp 2.27054504394531 gc 0.0)
+("srfi-13.bm: strings: searching: upcase downcase upcase! downcase!" 600 user 0.2 benchmark 0.199656677246094 bench/interp 0.199656677246094 gc 0.0)
+("srfi-13.bm: strings: readers: read token, method 1" 1200 user 1.26 benchmark 1.25931335449219 bench/interp 1.25931335449219 gc 0.0)
+("srfi-13.bm: strings: readers: read token, method 2" 1200 user 2.03 benchmark 2.02931335449219 bench/interp 2.02931335449219 gc 0.0)
+("subr.bm: subr invocation: simple subr" 700000 user 0.47 benchmark 0.069456787109375 bench/interp 0.069456787109375 gc 0.0)
+("subr.bm: subr invocation: generic subr" 700000 user 1.75 benchmark 1.34945678710938 bench/interp 1.34945678710938 gc 0.0)
+("subr.bm: subr invocation: generic subr with rest arg" 700000 user 1.39 benchmark 0.989456787109375 bench/interp 0.989456787109375 gc 0.0)
+("subr.bm: subr invocation: generic subr with rest arg and 3+ parameters" 700000 user 1.86 benchmark 1.45945678710938 bench/interp 1.45945678710938 gc 0.0)
+("subr.bm: subr application: simple subr" 700000 user 0.91 benchmark 0.509456787109375 bench/interp 0.509456787109375 gc 0.0)
+("subr.bm: subr application: generic subr" 700000 user 1.8 benchmark 1.39945678710938 bench/interp 1.39945678710938 gc 0.0)
+("subr.bm: subr application: generic subr with rest arg" 700000 user 1.44 benchmark 1.03945678710937 bench/interp 1.03945678710937 gc 0.0)
+("subr.bm: subr application: generic subr with rest arg and 3+ parameters" 700000 user 1.89 benchmark 1.48945678710937 bench/interp 1.48945678710937 gc 0.0)
+("uniform-vector-read.bm: uniform-vector-read!: uniform-vector-write" 500 user 0.12 benchmark 0.119713897705078 bench/interp 0.119713897705078 gc 0.0)
+("uniform-vector-read.bm: uniform-vector-read!: uniform-vector-read!" 500 user 0.02 benchmark 0.0197138977050781 bench/interp 0.0197138977050781 gc 0.0)
+("uniform-vector-read.bm: uniform-vector-read!: string port" 5000 user 2.49 benchmark 2.48713897705078 bench/interp 2.48713897705078 gc 0.0)
--- /dev/null
+eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}'
+ & eval 'exec perl -wS "$0" $argv:q'
+ if 0;
+# Generate a release announcement message.
+
+my $VERSION = '2009-11-20 13:36'; # UTC
+# The definition above must lie within the first 8 lines in order
+# for the Emacs time-stamp write hook (at end) to update it.
+# If you change this file with Emacs, please let the write hook
+# do its job. Otherwise, update this string manually.
+
+# Copyright (C) 2002-2009 Free Software Foundation, Inc.
+
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+
+# This program 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 General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# Written by Jim Meyering
+
+use strict;
+
+use Getopt::Long;
+use Digest::MD5;
+use Digest::SHA1;
+use POSIX qw(strftime);
+
+(my $ME = $0) =~ s|.*/||;
+
+my %valid_release_types = map {$_ => 1} qw (alpha beta stable);
+my @archive_suffixes = ('tar.gz', 'tar.bz2', 'tar.lzma', 'tar.xz');
+
+sub usage ($)
+{
+ my ($exit_code) = @_;
+ my $STREAM = ($exit_code == 0 ? *STDOUT : *STDERR);
+ if ($exit_code != 0)
+ {
+ print $STREAM "Try `$ME --help' for more information.\n";
+ }
+ else
+ {
+ my @types = sort keys %valid_release_types;
+ print $STREAM <<EOF;
+Usage: $ME [OPTIONS]
+Generate an announcement message.
+
+OPTIONS:
+
+These options must be specified:
+
+ --release-type=TYPE TYPE must be one of @types
+ --package-name=PACKAGE_NAME
+ --previous-version=VER
+ --current-version=VER
+ --gpg-key-id=ID The GnuPG ID of the key used to sign the tarballs
+ --url-directory=URL_DIR
+
+The following are optional:
+
+ --news=NEWS_FILE
+ --bootstrap-tools=TOOL_LIST a comma-separated list of tools, e.g.,
+ autoconf,automake,bison,gnulib
+ --gnulib-version=VERSION report VERSION as the gnulib version, where
+ VERSION is the result of running git describe
+ in the gnulib source directory.
+ required if gnulib is in TOOL_LIST.
+ --no-print-checksums do not emit MD5 or SHA1 checksums
+ --archive-suffix=SUF add SUF to the list of archive suffixes
+
+ --help display this help and exit
+ --version output version information and exit
+
+EOF
+ }
+ exit $exit_code;
+}
+
+
+=item C<%size> = C<sizes (@file)>
+
+Compute the sizes of the C<@file> and return them as a hash. Return
+C<undef> if one of the computation failed.
+
+=cut
+
+sub sizes (@)
+{
+ my (@file) = @_;
+
+ my $fail = 0;
+ my %res;
+ foreach my $f (@file)
+ {
+ my $cmd = "du --human $f";
+ my $t = `$cmd`;
+ # FIXME-someday: give a better diagnostic, a la $PROCESS_STATUS
+ $@
+ and (warn "$ME: command failed: `$cmd'\n"), $fail = 1;
+ chomp $t;
+ $t =~ s/^([\d.]+[MkK]).*/${1}B/;
+ $res{$f} = $t;
+ }
+ return $fail ? undef : %res;
+}
+
+=item C<print_locations ($title, \@url, \%size, @file)
+
+Print a section C<$title> dedicated to the list of <@file>, which
+sizes are stored in C<%size>, and which are available from the C<@url>.
+
+=cut
+
+sub print_locations ($\@\%@)
+{
+ my ($title, $url, $size, @file) = @_;
+ print "Here are the $title:\n";
+ foreach my $url (@{$url})
+ {
+ for my $file (@file)
+ {
+ print " $url/$file";
+ print " (", $$size{$file}, ")"
+ if exists $$size{$file};
+ print "\n";
+ }
+ }
+ print "\n";
+}
+
+=item C<print_checksums (@file)
+
+Print the MD5 and SHA1 signature section for each C<@file>.
+
+=cut
+
+sub print_checksums (@)
+{
+ my (@file) = @_;
+
+ print "Here are the MD5 and SHA1 checksums:\n";
+ print "\n";
+
+ foreach my $meth (qw (md5 sha1))
+ {
+ foreach my $f (@file)
+ {
+ open IN, '<', $f
+ or die "$ME: $f: cannot open for reading: $!\n";
+ binmode IN;
+ my $dig =
+ ($meth eq 'md5'
+ ? Digest::MD5->new->addfile(*IN)->hexdigest
+ : Digest::SHA1->new->addfile(*IN)->hexdigest);
+ close IN;
+ print "$dig $f\n";
+ }
+ }
+ print "\n";
+}
+
+=item C<print_news_deltas ($news_file, $prev_version, $curr_version)
+
+Print the section of the NEWS file C<$news_file> addressing changes
+between versions C<$prev_version> and C<$curr_version>.
+
+=cut
+
+sub print_news_deltas ($$$)
+{
+ my ($news_file, $prev_version, $curr_version) = @_;
+
+ print "\n$news_file\n\n";
+
+ # Print all lines from $news_file, starting with the first one
+ # that mentions $curr_version up to but not including
+ # the first occurrence of $prev_version.
+ my $in_items;
+
+ my $re_prefix = qr/(?:\* )?(?:Noteworthy c|Major c|C)(?i:hanges)/;
+
+ open NEWS, '<', $news_file
+ or die "$ME: $news_file: cannot open for reading: $!\n";
+ while (defined (my $line = <NEWS>))
+ {
+ if ( ! $in_items)
+ {
+ # Match lines like these:
+ # * Major changes in release 5.0.1:
+ # * Noteworthy changes in release 6.6 (2006-11-22) [stable]
+ $line =~ /^$re_prefix.*(?:[^\d.]|$)\Q$curr_version\E(?:[^\d.]|$)/o
+ or next;
+ $in_items = 1;
+ print $line;
+ }
+ else
+ {
+ # This regexp must not match version numbers in NEWS items.
+ # For example, they might well say `introduced in 4.5.5',
+ # and we don't want that to match.
+ $line =~ /^$re_prefix.*(?:[^\d.]|$)\Q$prev_version\E(?:[^\d.]|$)/o
+ and last;
+ print $line;
+ }
+ }
+ close NEWS;
+
+ $in_items
+ or die "$ME: $news_file: no matching lines for `$curr_version'\n";
+}
+
+sub print_changelog_deltas ($$)
+{
+ my ($package_name, $prev_version) = @_;
+
+ # Print new ChangeLog entries.
+
+ # First find all CVS-controlled ChangeLog files.
+ use File::Find;
+ my @changelog;
+ find ({wanted => sub {$_ eq 'ChangeLog' && -d 'CVS'
+ and push @changelog, $File::Find::name}},
+ '.');
+
+ # If there are no ChangeLog files, we're done.
+ @changelog
+ or return;
+ my %changelog = map {$_ => 1} @changelog;
+
+ # Reorder the list of files so that if there are ChangeLog
+ # files in the specified directories, they're listed first,
+ # in this order:
+ my @dir = qw ( . src lib m4 config doc );
+
+ # A typical @changelog array might look like this:
+ # ./ChangeLog
+ # ./po/ChangeLog
+ # ./m4/ChangeLog
+ # ./lib/ChangeLog
+ # ./doc/ChangeLog
+ # ./config/ChangeLog
+ my @reordered;
+ foreach my $d (@dir)
+ {
+ my $dot_slash = $d eq '.' ? $d : "./$d";
+ my $target = "$dot_slash/ChangeLog";
+ delete $changelog{$target}
+ and push @reordered, $target;
+ }
+
+ # Append any remaining ChangeLog files.
+ push @reordered, sort keys %changelog;
+
+ # Remove leading `./'.
+ @reordered = map { s!^\./!!; $_ } @reordered;
+
+ print "\nChangeLog entries:\n\n";
+ # print join ("\n", @reordered), "\n";
+
+ $prev_version =~ s/\./_/g;
+ my $prev_cvs_tag = "\U$package_name\E-$prev_version";
+
+ my $cmd = "cvs -n diff -u -r$prev_cvs_tag -rHEAD @reordered";
+ open DIFF, '-|', $cmd
+ or die "$ME: cannot run `$cmd': $!\n";
+ # Print two types of lines, making minor changes:
+ # Lines starting with `+++ ', e.g.,
+ # +++ ChangeLog 22 Feb 2003 16:52:51 -0000 1.247
+ # and those starting with `+'.
+ # Don't print the others.
+ my $prev_printed_line_empty = 1;
+ while (defined (my $line = <DIFF>))
+ {
+ if ($line =~ /^\+\+\+ /)
+ {
+ my $separator = "*"x70 ."\n";
+ $line =~ s///;
+ $line =~ s/\s.*//;
+ $prev_printed_line_empty
+ or print "\n";
+ print $separator, $line, $separator;
+ }
+ elsif ($line =~ /^\+/)
+ {
+ $line =~ s///;
+ print $line;
+ $prev_printed_line_empty = ($line =~ /^$/);
+ }
+ }
+ close DIFF;
+
+ # The exit code should be 1.
+ # Allow in case there are no modified ChangeLog entries.
+ $? == 256 || $? == 128
+ or warn "$ME: warning: `cmd' had unexpected exit code or signal ($?)\n";
+}
+
+sub get_tool_versions ($$)
+{
+ my ($tool_list, $gnulib_version) = @_;
+ @$tool_list
+ or return ();
+
+ my $fail;
+ my @tool_version_pair;
+ foreach my $t (@$tool_list)
+ {
+ if ($t eq 'gnulib')
+ {
+ push @tool_version_pair, ucfirst $t . ' ' . $gnulib_version;
+ next;
+ }
+ # Assume that the last "word" on the first line of
+ # `tool --version` output is the version string.
+ my ($first_line, undef) = split ("\n", `$t --version`);
+ if ($first_line =~ /.* (\d[\w.-]+)$/)
+ {
+ $t = ucfirst $t;
+ push @tool_version_pair, "$t $1";
+ }
+ else
+ {
+ defined $first_line
+ and $first_line = '';
+ warn "$ME: $t: unexpected --version output\n:$first_line";
+ $fail = 1;
+ }
+ }
+
+ $fail
+ and exit 1;
+
+ return @tool_version_pair;
+}
+
+{
+ # Neutralize the locale, so that, for instance, "du" does not
+ # issue "1,2" instead of "1.2", what confuses our regexps.
+ $ENV{LC_ALL} = "C";
+
+ my $release_type;
+ my $package_name;
+ my $prev_version;
+ my $curr_version;
+ my $gpg_key_id;
+ my @url_dir_list;
+ my @news_file;
+ my $bootstrap_tools;
+ my $gnulib_version;
+ my $print_checksums_p = 1;
+
+ GetOptions
+ (
+ 'release-type=s' => \$release_type,
+ 'package-name=s' => \$package_name,
+ 'previous-version=s' => \$prev_version,
+ 'current-version=s' => \$curr_version,
+ 'gpg-key-id=s' => \$gpg_key_id,
+ 'url-directory=s' => \@url_dir_list,
+ 'news=s' => \@news_file,
+ 'bootstrap-tools=s' => \$bootstrap_tools,
+ 'gnulib-version=s' => \$gnulib_version,
+ 'print-checksums!' => \$print_checksums_p,
+ 'archive-suffix=s' => \@archive_suffixes,
+
+ help => sub { usage 0 },
+ version => sub { print "$ME version $VERSION\n"; exit },
+ ) or usage 1;
+
+ my $fail = 0;
+ # Ensure that sure each required option is specified.
+ $release_type
+ or (warn "$ME: release type not specified\n"), $fail = 1;
+ $package_name
+ or (warn "$ME: package name not specified\n"), $fail = 1;
+ $prev_version
+ or (warn "$ME: previous version string not specified\n"), $fail = 1;
+ $curr_version
+ or (warn "$ME: current version string not specified\n"), $fail = 1;
+ $gpg_key_id
+ or (warn "$ME: GnuPG key ID not specified\n"), $fail = 1;
+ @url_dir_list
+ or (warn "$ME: URL directory name(s) not specified\n"), $fail = 1;
+
+ my @tool_list = split ',', $bootstrap_tools;
+
+ grep (/^gnulib$/, @tool_list) ^ defined $gnulib_version
+ and (warn "$ME: when specifying gnulib as a tool, you must also specify\n"
+ . "--gnulib-version=V, where V is the result of running git describe\n"
+ . "in the gnulib source directory.\n"), $fail = 1;
+
+ exists $valid_release_types{$release_type}
+ or (warn "$ME: `$release_type': invalid release type\n"), $fail = 1;
+
+ @ARGV
+ and (warn "$ME: too many arguments:\n", join ("\n", @ARGV), "\n"),
+ $fail = 1;
+ $fail
+ and usage 1;
+
+ my $my_distdir = "$package_name-$curr_version";
+
+ my $xd = "$package_name-$prev_version-$curr_version.xdelta";
+
+ my @candidates = map { "$my_distdir.$_" } @archive_suffixes;
+ my @tarballs = grep {-f $_} @candidates;
+
+ @tarballs
+ or die "$ME: none of " . join(', ', @candidates) . " were found\n";
+ my @sizable = @tarballs;
+ -f $xd
+ and push @sizable, $xd;
+ my %size = sizes (@sizable);
+ %size
+ or exit 1;
+
+ # The markup is escaped as <\# so that when this script is sent by
+ # mail (or part of a diff), Gnus is not triggered.
+ print <<EOF;
+
+Subject: $my_distdir released [$release_type]
+
+<\#secure method=pgpmime mode=sign>
+
+FIXME: put comments here
+
+EOF
+
+ print_locations ("compressed sources", @url_dir_list, %size, @tarballs);
+ -f $xd
+ and print_locations ("xdelta diffs (useful? if so, "
+ . "please tell bug-gnulib\@gnu.org)",
+ @url_dir_list, %size, $xd);
+ my @sig_files = map { "$_.sig" } @tarballs;
+ print_locations ("GPG detached signatures[*]", @url_dir_list, %size,
+ @sig_files);
+ if ($url_dir_list[0] =~ "gnu\.org")
+ {
+ print "To reduce load on the main server, use a mirror listed at:\n";
+ print " http://www.gnu.org/order/ftp.html\n\n";
+ }
+
+ $print_checksums_p
+ and print_checksums (@sizable);
+
+ print <<EOF;
+[*] You can use either of the above signature files to verify that
+the corresponding file (without the .sig suffix) is intact. First,
+be sure to download both the .sig file and the corresponding tarball.
+Then, run a command like this:
+
+ gpg --verify $tarballs[0].sig
+
+If that command fails because you don't have the required public key,
+then run this command to import it:
+
+ gpg --keyserver keys.gnupg.net --recv-keys $gpg_key_id
+
+and rerun the \`gpg --verify' command.
+EOF
+
+ my @tool_versions = get_tool_versions (\@tool_list, $gnulib_version);
+ @tool_versions
+ and print "\nThis release was bootstrapped with the following tools:",
+ join ('', map {"\n $_"} @tool_versions), "\n";
+
+ print_news_deltas ($_, $prev_version, $curr_version)
+ foreach @news_file;
+
+ $release_type eq 'stable'
+ or print_changelog_deltas ($package_name, $prev_version);
+
+ exit 0;
+}
+
+### Setup "GNU" style for perl-mode and cperl-mode.
+## Local Variables:
+## mode: perl
+## perl-indent-level: 2
+## perl-continued-statement-offset: 2
+## perl-continued-brace-offset: 0
+## perl-brace-offset: 0
+## perl-brace-imaginary-offset: 0
+## perl-label-offset: -2
+## perl-extra-newline-before-brace: t
+## perl-merge-trailing-else: nil
+## eval: (add-hook 'write-file-hooks 'time-stamp)
+## time-stamp-start: "my $VERSION = '"
+## time-stamp-format: "%:y-%02m-%02d %02H:%02M"
+## time-stamp-time-zone: "UTC"
+## time-stamp-end: "'; # UTC"
+## End:
--- /dev/null
+#!/bin/sh
+# gendocs.sh -- generate a GNU manual in many formats. This script is
+# mentioned in maintain.texi. See the help message below for usage details.
+
+scriptversion=2009-09-09.22
+
+# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009
+# Free Software Foundation, Inc.
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+#
+# Original author: Mohit Agarwal.
+# Send bug reports and any other correspondence to bug-texinfo@gnu.org.
+
+prog=`basename "$0"`
+srcdir=`pwd`
+
+scripturl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/util/gendocs.sh"
+templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/util/gendocs_template"
+
+: ${SETLANG="env LANG= LC_MESSAGES= LC_ALL= LANGUAGE="}
+: ${MAKEINFO="makeinfo"}
+: ${TEXI2DVI="texi2dvi -t @finalout"}
+: ${DVIPS="dvips"}
+: ${DOCBOOK2HTML="docbook2html"}
+: ${DOCBOOK2PDF="docbook2pdf"}
+: ${DOCBOOK2PS="docbook2ps"}
+: ${DOCBOOK2TXT="docbook2txt"}
+: ${GENDOCS_TEMPLATE_DIR="."}
+: ${TEXI2HTML="texi2html"}
+unset CDPATH
+unset use_texi2html
+
+version="gendocs.sh $scriptversion
+
+Copyright 2009 Free Software Foundation, Inc.
+There is NO warranty. You may redistribute this software
+under the terms of the GNU General Public License.
+For more information about these matters, see the files named COPYING."
+
+usage="Usage: $prog [OPTION]... PACKAGE MANUAL-TITLE
+
+Generate various output formats from PACKAGE.texinfo (or .texi or .txi) source.
+See the GNU Maintainers document for a more extensive discussion:
+ http://www.gnu.org/prep/maintain_toc.html
+
+Options:
+ -o OUTDIR write files into OUTDIR, instead of manual/.
+ --email ADR use ADR as contact in generated web pages.
+ --docbook convert to DocBook too (xml, txt, html, pdf and ps).
+ --html ARG pass indicated ARG to makeinfo or texi2html for HTML targets.
+ --texi2html use texi2html to generate HTML targets.
+ --help display this help and exit successfully.
+ --version display version information and exit successfully.
+
+Simple example: $prog --email bug-gnu-emacs@gnu.org emacs \"GNU Emacs Manual\"
+
+Typical sequence:
+ cd PACKAGESOURCE/doc
+ wget \"$scripturl\"
+ wget \"$templateurl\"
+ $prog --email BUGLIST MANUAL \"GNU MANUAL - One-line description\"
+
+Output will be in a new subdirectory \"manual\" (by default, use -o OUTDIR
+to override). Move all the new files into your web CVS tree, as
+explained in the Web Pages node of maintain.texi.
+
+Please use the --email ADDRESS option to specify your bug-reporting
+address in the generated HTML pages.
+
+MANUAL-TITLE is included as part of the HTML <title> of the overall
+manual/index.html file. It should include the name of the package being
+documented. manual/index.html is created by substitution from the file
+$GENDOCS_TEMPLATE_DIR/gendocs_template. (Feel free to modify the
+generic template for your own purposes.)
+
+If you have several manuals, you'll need to run this script several
+times with different MANUAL values, specifying a different output
+directory with -o each time. Then write (by hand) an overall index.html
+with links to them all.
+
+If a manual's Texinfo sources are spread across several directories,
+first copy or symlink all Texinfo sources into a single directory.
+(Part of the script's work is to make a tar.gz of the sources.)
+
+You can set the environment variables MAKEINFO, TEXI2DVI, and DVIPS to
+control the programs that get executed, and GENDOCS_TEMPLATE_DIR to
+control where the gendocs_template file is looked for. (With --docbook,
+the environment variables DOCBOOK2HTML, DOCBOOK2PDF, DOCBOOK2PS, and
+DOCBOOK2TXT are also respected.)
+
+By default, makeinfo is run in the default (English) locale, since
+that's the language of most Texinfo manuals. If you happen to have a
+non-English manual and non-English web site, see the SETLANG setting
+in the source.
+
+Email bug reports or enhancement requests to bug-texinfo@gnu.org.
+"
+
+calcsize()
+{
+ size=`ls -ksl $1 | awk '{print $1}'`
+ echo $size
+}
+
+MANUAL_TITLE=
+PACKAGE=
+EMAIL=webmasters@gnu.org # please override with --email
+htmlarg=
+outdir=manual
+
+while test $# -gt 0; do
+ case $1 in
+ --email) shift; EMAIL=$1;;
+ --help) echo "$usage"; exit 0;;
+ --version) echo "$version"; exit 0;;
+ -o) shift; outdir=$1;;
+ --docbook) docbook=yes;;
+ --html) shift; htmlarg=$1;;
+ --texi2html) use_texi2html=1;;
+ -*)
+ echo "$0: Unknown option \`$1'." >&2
+ echo "$0: Try \`--help' for more information." >&2
+ exit 1;;
+ *)
+ if test -z "$PACKAGE"; then
+ PACKAGE=$1
+ elif test -z "$MANUAL_TITLE"; then
+ MANUAL_TITLE=$1
+ else
+ echo "$0: extra non-option argument \`$1'." >&2
+ exit 1
+ fi;;
+ esac
+ shift
+done
+
+if test -s "$srcdir/$PACKAGE.texinfo"; then
+ srcfile=$srcdir/$PACKAGE.texinfo
+elif test -s "$srcdir/$PACKAGE.texi"; then
+ srcfile=$srcdir/$PACKAGE.texi
+elif test -s "$srcdir/$PACKAGE.txi"; then
+ srcfile=$srcdir/$PACKAGE.txi
+else
+ echo "$0: cannot find .texinfo or .texi or .txi for $PACKAGE in $srcdir." >&2
+ exit 1
+fi
+
+if test ! -r $GENDOCS_TEMPLATE_DIR/gendocs_template; then
+ echo "$0: cannot read $GENDOCS_TEMPLATE_DIR/gendocs_template." >&2
+ echo "$0: it is available from $templateurl." >&2
+ exit 1
+fi
+
+case $outdir in
+ /*) dotdot_outdir="$outdir";;
+ *) dotdot_outdir="../$outdir";;
+esac
+
+echo Generating output formats for $srcfile
+
+cmd="$SETLANG $MAKEINFO -o $PACKAGE.info \"$srcfile\""
+echo "Generating info files... ($cmd)"
+eval "$cmd"
+mkdir -p $outdir/
+tar czf $outdir/$PACKAGE.info.tar.gz $PACKAGE.info*
+info_tgz_size=`calcsize $outdir/$PACKAGE.info.tar.gz`
+# do not mv the info files, there's no point in having them available
+# separately on the web.
+
+cmd="${TEXI2DVI} \"$srcfile\""
+echo "Generating dvi ... ($cmd)"
+eval "$cmd"
+
+# now, before we compress dvi:
+echo Generating postscript...
+${DVIPS} $PACKAGE -o
+gzip -f -9 $PACKAGE.ps
+ps_gz_size=`calcsize $PACKAGE.ps.gz`
+mv $PACKAGE.ps.gz $outdir/
+
+# compress/finish dvi:
+gzip -f -9 $PACKAGE.dvi
+dvi_gz_size=`calcsize $PACKAGE.dvi.gz`
+mv $PACKAGE.dvi.gz $outdir/
+
+cmd="${TEXI2DVI} --pdf \"$srcfile\""
+echo "Generating pdf ... ($cmd)"
+eval "$cmd"
+pdf_size=`calcsize $PACKAGE.pdf`
+mv $PACKAGE.pdf $outdir/
+
+cmd="$SETLANG $MAKEINFO -o $PACKAGE.txt --no-split --no-headers \"$srcfile\""
+echo "Generating ASCII... ($cmd)"
+eval "$cmd"
+ascii_size=`calcsize $PACKAGE.txt`
+gzip -f -9 -c $PACKAGE.txt >$outdir/$PACKAGE.txt.gz
+ascii_gz_size=`calcsize $outdir/$PACKAGE.txt.gz`
+mv $PACKAGE.txt $outdir/
+
+html_split()
+{
+ opt="--split=$1 $htmlarg --node-files"
+ cmd="$SETLANG $TEXI2HTML --output $PACKAGE.html $opt \"$srcfile\""
+ echo "Generating html by $1... ($cmd)"
+ eval "$cmd"
+ split_html_dir=$PACKAGE.html
+ (
+ cd ${split_html_dir} || exit 1
+ ln -sf ${PACKAGE}.html index.html
+ tar -czf $dotdot_outdir/${PACKAGE}.html_$1.tar.gz -- *.html
+ )
+ eval html_$1_tgz_size=`calcsize $outdir/${PACKAGE}.html_$1.tar.gz`
+ rm -f $outdir/html_$1/*.html
+ mkdir -p $outdir/html_$1/
+ mv ${split_html_dir}/*.html $outdir/html_$1/
+ rmdir ${split_html_dir}
+}
+
+if test -z "$use_texi2html"; then
+ opt="--no-split --html -o $PACKAGE.html $htmlarg"
+ cmd="$SETLANG $MAKEINFO $opt \"$srcfile\""
+ echo "Generating monolithic html... ($cmd)"
+ rm -rf $PACKAGE.html # in case a directory is left over
+ eval "$cmd"
+ html_mono_size=`calcsize $PACKAGE.html`
+ gzip -f -9 -c $PACKAGE.html >$outdir/$PACKAGE.html.gz
+ html_mono_gz_size=`calcsize $outdir/$PACKAGE.html.gz`
+ mv $PACKAGE.html $outdir/
+
+ cmd="$SETLANG $MAKEINFO --html -o $PACKAGE.html $htmlarg \"$srcfile\""
+ echo "Generating html by node... ($cmd)"
+ eval "$cmd"
+ split_html_dir=$PACKAGE.html
+ (
+ cd ${split_html_dir} || exit 1
+ tar -czf $dotdot_outdir/${PACKAGE}.html_node.tar.gz -- *.html
+ )
+ html_node_tgz_size=`calcsize $outdir/${PACKAGE}.html_node.tar.gz`
+ rm -f $outdir/html_node/*.html
+ mkdir -p $outdir/html_node/
+ mv ${split_html_dir}/*.html $outdir/html_node/
+ rmdir ${split_html_dir}
+else
+ cmd="$SETLANG $TEXI2HTML --output $PACKAGE.html $htmlarg \"$srcfile\""
+ echo "Generating monolithic html... ($cmd)"
+ rm -rf $PACKAGE.html # in case a directory is left over
+ eval "$cmd"
+ html_mono_size=`calcsize $PACKAGE.html`
+ gzip -f -9 -c $PACKAGE.html >$outdir/$PACKAGE.html.gz
+ html_mono_gz_size=`calcsize $outdir/$PACKAGE.html.gz`
+ mv $PACKAGE.html $outdir/
+
+ html_split node
+ html_split chapter
+ html_split section
+fi
+
+echo Making .tar.gz for sources...
+srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null`
+tar cvzfh $outdir/$PACKAGE.texi.tar.gz $srcfiles
+texi_tgz_size=`calcsize $outdir/$PACKAGE.texi.tar.gz`
+
+if test -n "$docbook"; then
+ cmd="$SETLANG $MAKEINFO -o - --docbook \"$srcfile\" > ${srcdir}/$PACKAGE-db.xml"
+ echo "Generating docbook XML... $(cmd)"
+ eval "$cmd"
+ docbook_xml_size=`calcsize $PACKAGE-db.xml`
+ gzip -f -9 -c $PACKAGE-db.xml >$outdir/$PACKAGE-db.xml.gz
+ docbook_xml_gz_size=`calcsize $outdir/$PACKAGE-db.xml.gz`
+ mv $PACKAGE-db.xml $outdir/
+
+ cmd="${DOCBOOK2HTML} -o $split_html_db_dir ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook HTML... ($cmd)"
+ eval "$cmd"
+ split_html_db_dir=html_node_db
+ (
+ cd ${split_html_db_dir} || exit 1
+ tar -czf $dotdot_outdir/${PACKAGE}.html_node_db.tar.gz -- *.html
+ )
+ html_node_db_tgz_size=`calcsize $outdir/${PACKAGE}.html_node_db.tar.gz`
+ rm -f $outdir/html_node_db/*.html
+ mkdir -p $outdir/html_node_db
+ mv ${split_html_db_dir}/*.html $outdir/html_node_db/
+ rmdir ${split_html_db_dir}
+
+ cmd="${DOCBOOK2TXT} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook ASCII... ($cmd)"
+ eval "$cmd"
+ docbook_ascii_size=`calcsize $PACKAGE-db.txt`
+ mv $PACKAGE-db.txt $outdir/
+
+ cmd="${DOCBOOK2PS} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook PS... $(cmd)"
+ eval "$cmd"
+ gzip -f -9 -c $PACKAGE-db.ps >$outdir/$PACKAGE-db.ps.gz
+ docbook_ps_gz_size=`calcsize $outdir/$PACKAGE-db.ps.gz`
+ mv $PACKAGE-db.ps $outdir/
+
+ cmd="${DOCBOOK2PDF} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook PDF... ($cmd)"
+ eval "$cmd"
+ docbook_pdf_size=`calcsize $PACKAGE-db.pdf`
+ mv $PACKAGE-db.pdf $outdir/
+fi
+
+echo "Writing index file..."
+if test -z "$use_texi2html"; then
+ CONDS="/%%IF *HTML_SECTION%%/,/%%ENDIF *HTML_SECTION%%/d;\
+ /%%IF *HTML_CHAPTER%%/,/%%ENDIF *HTML_CHAPTER%%/d"
+else
+ CONDS="/%%ENDIF.*%%/d;/%%IF *HTML_SECTION%%/d;/%%IF *HTML_CHAPTER%%/d"
+fi
+curdate=`$SETLANG date '+%B %d, %Y'`
+sed \
+ -e "s!%%TITLE%%!$MANUAL_TITLE!g" \
+ -e "s!%%EMAIL%%!$EMAIL!g" \
+ -e "s!%%PACKAGE%%!$PACKAGE!g" \
+ -e "s!%%DATE%%!$curdate!g" \
+ -e "s!%%HTML_MONO_SIZE%%!$html_mono_size!g" \
+ -e "s!%%HTML_MONO_GZ_SIZE%%!$html_mono_gz_size!g" \
+ -e "s!%%HTML_NODE_TGZ_SIZE%%!$html_node_tgz_size!g" \
+ -e "s!%%HTML_SECTION_TGZ_SIZE%%!$html_section_tgz_size!g" \
+ -e "s!%%HTML_CHAPTER_TGZ_SIZE%%!$html_chapter_tgz_size!g" \
+ -e "s!%%INFO_TGZ_SIZE%%!$info_tgz_size!g" \
+ -e "s!%%DVI_GZ_SIZE%%!$dvi_gz_size!g" \
+ -e "s!%%PDF_SIZE%%!$pdf_size!g" \
+ -e "s!%%PS_GZ_SIZE%%!$ps_gz_size!g" \
+ -e "s!%%ASCII_SIZE%%!$ascii_size!g" \
+ -e "s!%%ASCII_GZ_SIZE%%!$ascii_gz_size!g" \
+ -e "s!%%TEXI_TGZ_SIZE%%!$texi_tgz_size!g" \
+ -e "s!%%DOCBOOK_HTML_NODE_TGZ_SIZE%%!$html_node_db_tgz_size!g" \
+ -e "s!%%DOCBOOK_ASCII_SIZE%%!$docbook_ascii_size!g" \
+ -e "s!%%DOCBOOK_PS_GZ_SIZE%%!$docbook_ps_gz_size!g" \
+ -e "s!%%DOCBOOK_PDF_SIZE%%!$docbook_pdf_size!g" \
+ -e "s!%%DOCBOOK_XML_SIZE%%!$docbook_xml_size!g" \
+ -e "s!%%DOCBOOK_XML_GZ_SIZE%%!$docbook_xml_gz_size!g" \
+ -e "s,%%SCRIPTURL%%,$scripturl,g" \
+ -e "s!%%SCRIPTNAME%%!$prog!g" \
+ -e "$CONDS" \
+$GENDOCS_TEMPLATE_DIR/gendocs_template >$outdir/index.html
+
+echo "Done, see $outdir/ subdirectory for new files."
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-end: "$"
+# End:
-#!/usr/bin/perl
+eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}'
+ & eval 'exec perl -wS "$0" $argv:q'
+ if 0;
# Convert git log output to ChangeLog format.
-my $VERSION = '2009-06-04 08:53'; # UTC
+my $VERSION = '2009-10-30 13:46'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
--since=DATE convert only the logs since DATE;
the default is to convert all log entries.
+ --format=FMT set format string for commit subject and body;
+ see 'man git-log' for the list of format metacharacters;
+ the default is '%s%n%b%n'
--help display this help and exit
--version output version information and exit
{
my $since_date = '1970-01-01 UTC';
+ my $format_string = '%s%n%b%n';
GetOptions
(
help => sub { usage 0 },
version => sub { print "$ME version $VERSION\n"; exit },
'since=s' => \$since_date,
+ 'format=s' => \$format_string,
) or usage 1;
my @cmd = (qw (git log --log-size), "--since=$since_date",
- '--pretty=format:%ct %an <%ae>%n%n%s%n%b%n', @ARGV);
+ '--pretty=format:%ct %an <%ae>%n%n'.$format_string, @ARGV);
open PIPE, '-|', @cmd
or die ("$ME: failed to run `". quoted_cmd (@cmd) ."': $!\n"
. "(Is your Git too old? Version 1.5.1 or later is required.)\n");
}
# Local Variables:
+# mode: perl
# indent-tabs-mode: nil
# eval: (add-hook 'write-file-hooks 'time-stamp)
# time-stamp-start: "my $VERSION = '"
--- /dev/null
+#!/bin/sh
+# Run this after each non-alpha release, to update the web documentation at
+# http://www.gnu.org/software/$pkg/manual/
+# This script must be run from the top-level directory,
+# assumes you're using git for revision control,
+# and requires a .prev-version file as well as a Makefile,
+# from which it extracts the version number and package name, respectively.
+# Also, it assumes all documentation is in the doc/ sub-directory.
+
+VERSION=2009-07-21.16; # UTC
+
+# Copyright (C) 2009 Free Software Foundation, Inc.
+
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+
+# This program 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 General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# Requirements: everything required to bootstrap your package,
+# plus these: git, cvs, cvsu, rsync, mktemp
+
+ME=`basename "$0"`
+warn() { printf '%s: %s\n' "$ME" "$*" >&2; }
+die() { warn "$*"; exit 1; }
+
+help_version()
+{
+ case $1 in
+ --help) cat <<EOF
+Usage: $ME
+
+Run this script (no options or arguments) after each non-alpha release,
+to update the web documentation at http://www.gnu.org/software/\$pkg/manual/
+Run it from your project's the top-level directory.
+
+Options:
+ --help print this help, then exit
+ --version print version number, then exit
+
+Report bugs and patches to <bug-gnulib@gnu.org>.
+EOF
+ exit ;;
+
+ --version)
+ year=`echo "$VERSION" | sed 's/[^0-9].*//'`
+ cat <<EOF
+$ME $VERSION
+Copyright (C) $year Free Software Foundation, Inc,
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.
+EOF
+ exit ;;
+
+ *) die "unrecognized option: $1";;
+ esac
+}
+
+case $# in
+ 0) ;;
+ 1) help_version $1 ;;
+ *) die "$ME: too many options" ;;
+esac
+
+prev=.prev-version
+version=$(cat $prev) || die "$ME: no $prev file?"
+pkg=$(sed -n 's/^PACKAGE = \(.*\)/\1/p' Makefile) || die "$ME: no Makefile?"
+tmp_branch=web-doc-$version-$$
+
+cleanup()
+{
+ __st=$?;
+ rm -rf "$tmp"
+ git checkout master
+ git branch -d $tmp_branch
+ exit $__st
+}
+trap cleanup 0
+trap 'exit $?' 1 2 13 15
+
+# We must build using sources for which --version reports the
+# just-released version number, not some string like 7.6.18-20761.
+# That version string propagates into all documentation.
+git checkout -b $tmp_branch v$version
+./bootstrap && ./configure && make && make web-manual
+
+tmp=$(mktemp -d --tmpdir=. web-doc-update.XXXXXX) || exit 1
+( cd $tmp \
+ && cvs -d $USER@cvs.sv.gnu.org:/webcvs/$pkg co $pkg )
+rsync -avP doc/manual/ $tmp/$pkg/manual
+
+(
+ cd $tmp/$pkg/manual
+
+ # Add any new files:
+ cvsu --types='?'|sed s/..// | xargs --no-run-if-empty -- cvs add -ko
+
+ cvs ci -m $version
+)
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "VERSION="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-time-zone: "UTC"
+# time-stamp-end: "; # UTC"
+# End:
--- /dev/null
+#!/bin/sh
+# Sign files and upload them.
+
+scriptversion=2009-04-28.21; # UTC
+
+# Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3, or (at your option)
+# any later version.
+#
+# This program 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# Originally written by Alexandre Duret-Lutz <adl@gnu.org>.
+
+set -e
+
+GPG='gpg --batch --no-tty'
+conffile=.gnuploadrc
+to=
+dry_run=false
+symlink_files=
+delete_files=
+delete_symlinks=
+collect_var=
+dbg=
+
+usage="Usage: $0 [OPTIONS]... [COMMAND] FILES... [[COMMAND] FILES...]
+
+Sign all FILES, and upload them to selected destinations, according to
+<http://www.gnu.org/prep/maintain/html_node/Automated-FTP-Uploads.html>.
+
+Commands:
+ --delete delete FILES from destination
+ --symlink create symbolic links
+ --rmsymlink remove symbolic links
+ -- treat the remaining arguments as files to upload
+
+Options:
+ --help print this help text and exit
+ --to DEST specify one destination for FILES
+ (multiple --to options are allowed)
+ --user NAME sign with key NAME
+ --symlink-regex[=EXPR] use sed script EXPR to compute symbolic link names
+ --dry-run do nothing, show what would have been done
+ --version output version information and exit
+
+If --symlink-regex is given without EXPR, then the link target name
+is created by replacing the version information with \`-latest', e.g.:
+
+ foo-1.3.4.tar.gz -> foo-latest.tar.gz
+
+Recognized destinations are:
+ alpha.gnu.org:DIRECTORY
+ savannah.gnu.org:DIRECTORY
+ savannah.nongnu.org:DIRECTORY
+ ftp.gnu.org:DIRECTORY
+ build directive files and upload files by FTP
+ download.gnu.org.ua:{alpha|ftp}/DIRECTORY
+ build directive files and upload files by SFTP
+ [user@]host:DIRECTORY upload files with scp
+
+Options and commands are applied in order. If the file $conffile exists
+in the current working directory, its contents are prepended to the
+actual command line options. Use this to keep your defaults. Comments
+(#) and empty lines in $conffile are allowed.
+
+Examples:
+1. Upload automake-1.8.2b.tar.gz and automake-1.8.2b.tar.bz2 to two sites:
+ gnupload --to sources.redhat.com:~ftp/pub/automake \\
+ --to alpha.gnu.org:automake \\
+ automake-1.8.2b.tar.gz automake-1.8.2b.tar.bz2
+
+2. Same as above, but also create symbolic links to automake-latest.tar.*:
+ gnupload --to sources.redhat.com:~ftp/pub/automake \\
+ --to alpha.gnu.org:automake \\
+ --symlink-regex \\
+ automake-1.8.2b.tar.gz automake-1.8.2b.tar.bz2
+
+3. Symlink automake-1.8.2b.tar.gz to automake-latest.tar.gz and
+automake-1.8.2b.tar.bz2 to automake-latest.tar.bz2 on both sites:
+
+ gnupload --to sources.redhat.com:~ftp/pub/automake \\
+ --to alpha.gnu.org:automake \\
+ --symlink automake-1.8.2b.tar.gz automake-latest.tar.gz \\
+ automake-1.8.2b.tar.bz2 automake-latest.tar.bz2
+
+4. Delete automake-1.8.2a.tar.gz and .bz2, remove symlink
+automake-latest.tar.gz and upload automake-1.8.2b.tar.gz:
+
+ gnupload --to sources.redhat.com:~ftp/pub/automake \\
+ --to alpha.gnu.org:automake \\
+ --delete automake-1.8.2a.tar.gz automake-1.8.2a.tar.bz2 \\
+ --rmsymlink automake-latest.tar.gz \\
+ -- \\
+ automake-1.8.2b.tar.gz automake-1.8.2b.tar.bz2
+
+Report bugs to <bug-automake@gnu.org>.
+Send patches to <automake-patches@gnu.org>."
+
+# Read local configuration file
+if test -r "$conffile"; then
+ echo "$0: Reading configuration file $conffile"
+ eval set x "`sed 's/#.*$//;/^$/d' \"$conffile\" | tr '\012\015' ' '` \"\$@\""
+ shift
+fi
+
+while test -n "$1"; do
+ case $1 in
+ -*)
+ collect_var=
+ case $1 in
+ --help)
+ echo "$usage"
+ exit $?
+ ;;
+ --to)
+ if test -z "$2"; then
+ echo "$0: Missing argument for --to" 1>&2
+ exit 1
+ else
+ to="$to $2"
+ shift
+ fi
+ ;;
+ --user)
+ if test -z "$2"; then
+ echo "$0: Missing argument for --user" 1>&2
+ exit 1
+ else
+ GPG="$GPG --local-user $2"
+ shift
+ fi
+ ;;
+ --delete)
+ collect_var=delete_files
+ ;;
+ --rmsymlink)
+ collect_var=delete_symlinks
+ ;;
+ --symlink-regex=*)
+ symlink_expr=`expr "$1" : '[^=]*=\(.*\)'`
+ ;;
+ --symlink-regex)
+ symlink_expr='s|-[0-9][0-9\.]*\(-[0-9][0-9]*\)\{0,1\}\.|-latest.|'
+ ;;
+ --symlink)
+ collect_var=symlink_files
+ ;;
+ --dry-run|-n)
+ dry_run=:
+ ;;
+ --version)
+ echo "gnupload $scriptversion"
+ exit $?
+ ;;
+ --)
+ shift
+ break
+ ;;
+ -*)
+ echo "$0: Unknown option \`$1', try \`$0 --help'" 1>&2
+ exit 1
+ ;;
+ esac
+ ;;
+ *)
+ if test -z "$collect_var"; then
+ break
+ else
+ eval "$collect_var=\"\$$collect_var $1\""
+ fi
+ ;;
+ esac
+ shift
+done
+
+dprint()
+{
+ echo "Running $*..."
+}
+
+if $dry_run; then
+ dbg=dprint
+fi
+
+if test -z "$to"; then
+ echo "$0: Missing destination sites" >&2
+ exit 1
+fi
+
+if test -n "$symlink_files"; then
+ x=`echo "$symlink_files" | sed 's/[^ ]//g;s/ //g'`
+ if test -n "$x"; then
+ echo "$0: Odd number of symlink arguments" >&2
+ exit 1
+ fi
+fi
+
+if test $# = 0; then
+ if test -z "${symlink_files}${delete_files}${delete_symlinks}"; then
+ echo "$0: No file to upload" 1>&2
+ exit 1
+ fi
+else
+ # Make sure all files exist. We don't want to ask
+ # for the passphrase if the script will fail.
+ for file
+ do
+ if test ! -f $file; then
+ echo "$0: Cannot find \`$file'" 1>&2
+ exit 1
+ elif test -n "$symlink_expr"; then
+ linkname=`echo $file | sed "$symlink_expr"`
+ if test -z "$linkname"; then
+ echo "$0: symlink expression produces empty results" >&2
+ exit 1
+ elif test "$linkname" = $file; then
+ echo "$0: symlink expression does not alter file name" >&2
+ exit 1
+ fi
+ fi
+ done
+fi
+
+# Make sure passphrase is not exported in the environment.
+unset passphrase
+
+# Reset PATH to be sure that echo is a built-in. We will later use
+# `echo $passphrase' to output the passphrase, so it is important that
+# it is a built-in (third-party programs tend to appear in `ps'
+# listings with their arguments...).
+# Remember this script runs with `set -e', so if echo is not built-in
+# it will exit now.
+PATH=/empty echo -n "Enter GPG passphrase: "
+stty -echo
+read -r passphrase
+stty echo
+echo
+
+if test $# -ne 0; then
+ for file
+ do
+ echo "Signing $file..."
+ rm -f $file.sig
+ echo "$passphrase" | $dbg $GPG --passphrase-fd 0 -ba -o $file.sig $file
+ done
+fi
+
+
+# mkdirective DESTDIR BASE FILE STMT
+# Arguments: See upload, below
+mkdirective ()
+{
+ stmt="$4"
+ if test -n "$3"; then
+ stmt="
+filename: $3$stmt"
+ fi
+
+ cat >${2}.directive<<EOF
+version: 1.1
+directory: $1
+comment: gnupload v. $scriptversion$stmt
+EOF
+ if $dry_run; then
+ echo "File ${2}.directive:"
+ cat ${2}.directive
+ echo "File ${2}.directive:" | sed 's/./-/g'
+ fi
+}
+
+mksymlink ()
+{
+ while test $# -ne 0
+ do
+ echo "symlink: $1 $2"
+ shift
+ shift
+ done
+}
+
+# upload DEST DESTDIR BASE FILE STMT FILES
+# Arguments:
+# DEST Destination site;
+# DESTDIR Destination directory;
+# BASE Base name for the directive file;
+# FILE Name of the file to distribute (may be empty);
+# STMT Additional statements for the directive file;
+# FILES List of files to upload.
+upload ()
+{
+ dest=$1
+ destdir=$2
+ base=$3
+ file=$4
+ stmt=$5
+ files=$6
+
+ rm -f $base.directive $base.directive.asc
+ case $dest in
+ alpha.gnu.org:*)
+ mkdirective "$destdir" "$base" "$file" "$stmt"
+ echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign $base.directive
+ $dbg ncftpput ftp-upload.gnu.org /incoming/alpha $files $base.directive.asc
+ ;;
+ ftp.gnu.org:*)
+ mkdirective "$destdir" "$base" "$file" "$stmt"
+ echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign $base.directive
+ $dbg ncftpput ftp-upload.gnu.org /incoming/ftp $files $base.directive.asc
+ ;;
+ savannah.gnu.org:*)
+ if test -z "$files"; then
+ echo "$0: warning: standalone directives not applicable for $dest" >&2
+ fi
+ $dbg ncftpput savannah.gnu.org /incoming/savannah/$destdir $files
+ ;;
+ savannah.nongnu.org:*)
+ if test -z "$files"; then
+ echo "$0: warning: standalone directives not applicable for $dest" >&2
+ fi
+ $dbg ncftpput savannah.nongnu.org /incoming/savannah/$destdir $files
+ ;;
+ download.gnu.org.ua:alpha/*|download.gnu.org.ua:ftp/*)
+ destdir_p1=`echo "$destdir" | sed 's,^[^/]*/,,'`
+ destdir_topdir=`echo "$destdir" | sed 's,/.*,,'`
+ mkdirective "$destdir_p1" "$base" "$file" "$stmt"
+ echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign $base.directive
+ for f in $files $base.directive.asc
+ do
+ echo put $f
+ done | $dbg sftp -b - puszcza.gnu.org.ua:/incoming/$destdir_topdir
+ ;;
+ /*)
+ dest_host=`echo "$dest" | sed 's,:.*,,'`
+ mkdirective "$destdir" "$base" "$file" "$stmt"
+ echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign $base.directive
+ $dbg cp $files $base.directive.asc $dest_host
+ ;;
+ *)
+ if test -z "$files"; then
+ echo "$0: warning: standalone directives not applicable for $dest" >&2
+ fi
+ $dbg scp $files $dest
+ ;;
+ esac
+ rm -f $base.directive $base.directive.asc
+}
+
+#####
+# Process any standalone directives
+stmt=
+if test -n "$symlink_files"; then
+ stmt="$stmt
+`mksymlink $symlink_files`"
+fi
+
+for file in $delete_files
+do
+ stmt="$stmt
+archive: $file"
+done
+
+for file in $delete_symlinks
+do
+ stmt="$stmt
+rmsymlink: $file"
+done
+
+if test -n "$stmt"; then
+ for dest in $to
+ do
+ destdir=`echo $dest | sed 's/[^:]*://'`
+ upload "$dest" "$destdir" "`hostname`-$$" "" "$stmt"
+ done
+fi
+
+# Process actual uploads
+for dest in $to
+do
+ for file
+ do
+ echo "Uploading $file to $dest..."
+ stmt=
+ files="$file $file.sig"
+ destdir=`echo $dest | sed 's/[^:]*://'`
+ if test -n "$symlink_expr"; then
+ linkname=`echo $file | sed "$symlink_expr"`
+ stmt="$stmt
+symlink: $file $linkname
+symlink: $file.sig $linkname.sig"
+ fi
+ upload "$dest" "$destdir" "$file" "$file" "$stmt" "$files"
+ done
+done
+
+exit 0
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-time-zone: "UTC"
+# time-stamp-end: "; # UTC"
+# End:
--- /dev/null
+eval '(exit $?0)' && eval 'exec perl -wST "$0" ${1+"$@"}'
+ & eval 'exec perl -wST "$0" $argv:q'
+ if 0;
+# Detect instances of "if (p) free (p);".
+# Likewise for "if (p != NULL) free (p);". And with braces.
+# Also detect "if (NULL != p) free (p);".
+# And with 0 in place of NULL.
+
+my $VERSION = '2009-04-16 15:57'; # UTC
+# The definition above must lie within the first 8 lines in order
+# for the Emacs time-stamp write hook (at end) to update it.
+# If you change this file with Emacs, please let the write hook
+# do its job. Otherwise, update this string manually.
+
+# Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+
+# This program 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 General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# Written by Jim Meyering
+
+use strict;
+use warnings;
+use Getopt::Long;
+
+(my $ME = $0) =~ s|.*/||;
+
+# use File::Coda; # http://meyering.net/code/Coda/
+END {
+ defined fileno STDOUT or return;
+ close STDOUT and return;
+ warn "$ME: failed to close standard output: $!\n";
+ $? ||= 1;
+}
+
+sub usage ($)
+{
+ my ($exit_code) = @_;
+ my $STREAM = ($exit_code == 0 ? *STDOUT : *STDERR);
+ if ($exit_code != 0)
+ {
+ print $STREAM "Try `$ME --help' for more information.\n";
+ }
+ else
+ {
+ print $STREAM <<EOF;
+Usage: $ME [OPTIONS] FILE...
+
+Detect any instance in FILE of a useless "if" test before a free call, e.g.,
+"if (p) free (p);". Any such test may be safely removed without affecting
+the semantics of the C code in FILE. Use --name=FOO --name=BAR to also
+detect free-like functions named FOO and BAR.
+
+OPTIONS:
+
+ --list print only the name of each matching FILE (\0-terminated)
+ --name=N add name N to the list of \`free\'-like functions to detect;
+ may be repeated
+
+ --help display this help and exit
+ --version output version information and exit
+
+Exit status:
+
+ 0 one or more matches
+ 1 no match
+ 2 an error
+
+EXAMPLE:
+
+For example, this command prints all removable "if" tests before "free"
+and "kfree" calls in the linux kernel sources:
+
+ git ls-files -z |xargs -0 $ME --name=kfree
+
+EOF
+ }
+ exit $exit_code;
+}
+
+sub is_NULL ($)
+{
+ my ($expr) = @_;
+ return ($expr eq 'NULL' || $expr eq '0');
+}
+
+{
+ sub EXIT_MATCH {0}
+ sub EXIT_NO_MATCH {1}
+ sub EXIT_ERROR {2}
+ my $err = EXIT_NO_MATCH;
+
+ my $list;
+ my @name = qw(free);
+ GetOptions
+ (
+ help => sub { usage 0 },
+ version => sub { print "$ME version $VERSION\n"; exit },
+ list => \$list,
+ 'name=s@' => \@name,
+ ) or usage 1;
+
+ # Make sure we have the right number of non-option arguments.
+ # Always tell the user why we fail.
+ @ARGV < 1
+ and (warn "$ME: missing FILE argument\n"), usage EXIT_ERROR;
+
+ my $or = join '|', @name;
+ my $regexp = qr/(?:$or)/;
+
+ # Set the input record separator.
+ # Note: this makes it impractical to print line numbers.
+ $/ = '"';
+
+ my $found_match = 0;
+ FILE:
+ foreach my $file (@ARGV)
+ {
+ open FH, '<', $file
+ or (warn "$ME: can't open `$file' for reading: $!\n"),
+ $err = EXIT_ERROR, next;
+ while (defined (my $line = <FH>))
+ {
+ while ($line =~
+ /\b(if\s*\(\s*([^)]+?)(?:\s*!=\s*([^)]+?))?\s*\)
+ # 1 2 3
+ (?: \s*$regexp\s*\((?:\s*\([^)]+\))?\s*([^)]+)\)|
+ \s*\{\s*$regexp\s*\((?:\s*\([^)]+\))?\s*([^)]+)\)\s*;\s*\}))/sxg)
+ {
+ my $all = $1;
+ my ($lhs, $rhs) = ($2, $3);
+ my ($free_opnd, $braced_free_opnd) = ($4, $5);
+ my $non_NULL;
+ if (!defined $rhs) { $non_NULL = $lhs }
+ elsif (is_NULL $rhs) { $non_NULL = $lhs }
+ elsif (is_NULL $lhs) { $non_NULL = $rhs }
+ else { next }
+
+ # Compare the non-NULL part of the "if" expression and the
+ # free'd expression, without regard to white space.
+ $non_NULL =~ tr/ \t//d;
+ my $e2 = defined $free_opnd ? $free_opnd : $braced_free_opnd;
+ $e2 =~ tr/ \t//d;
+ if ($non_NULL eq $e2)
+ {
+ $found_match = 1;
+ $list
+ and (print "$file\0"), next FILE;
+ print "$file: $all\n";
+ }
+ }
+ }
+ }
+ continue
+ {
+ close FH;
+ }
+
+ $found_match && $err == EXIT_NO_MATCH
+ and $err = EXIT_MATCH;
+
+ exit $err;
+}
+
+my $foo = <<'EOF';
+# The above is to *find* them.
+# This adjusts them, removing the unnecessary "if (p)" part.
+
+# FIXME: do something like this as an option (doesn't do braces):
+free=xfree
+git grep -l -z "$free *(" \
+ | xargs -0 useless-if-before-free -l --name="$free" \
+ | xargs -0 perl -0x3b -pi -e \
+ 's/\bif\s*\(\s*(\S+?)(?:\s*!=\s*(?:0|NULL))?\s*\)\s+('"$free"'\s*\((?:\s*\([^)]+\))?\s*\1\s*\))/$2/s'
+
+# Use the following to remove redundant uses of kfree inside braces.
+# Note that -0777 puts perl in slurp-whole-file mode;
+# but we have plenty of memory, these days...
+free=kfree
+git grep -l -z "$free *(" \
+ | xargs -0 useless-if-before-free -l --name="$free" \
+ | xargs -0 perl -0777 -pi -e \
+ 's/\bif\s*\(\s*(\S+?)(?:\s*!=\s*(?:0|NULL))?\s*\)\s*\{\s*('"$free"'\s*\((?:\s*\([^)]+\))?\s*\1\s*\);)\s*\}[^\n]*$/$2/gms'
+
+Be careful that the result of the above transformation is valid.
+If the matched string is followed by "else", then obviously, it won't be.
+
+When modifying files, refuse to process anything other than a regular file.
+EOF
+
+## Local Variables:
+## mode: perl
+## indent-tabs-mode: nil
+## eval: (add-hook 'write-file-hooks 'time-stamp)
+## time-stamp-start: "my $VERSION = '"
+## time-stamp-format: "%:y-%02m-%02d %02H:%02M"
+## time-stamp-time-zone: "UTC"
+## time-stamp-end: "'; # UTC"
+## End:
--- /dev/null
+#!/bin/sh
+# List version-controlled file names.
+
+# Print a version string.
+scriptversion=2009-07-21.16; # UTC
+
+# Copyright (C) 2006-2009 Free Software Foundation, Inc.
+
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+
+# This program 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 General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+# List the specified version-controlled files.
+# With no argument, list them all. With a single DIRECTORY argument,
+# list the version-controlled files in that directory.
+
+# If there's an argument, it must be a single, "."-relative directory name.
+# cvsu is part of the cvsutils package: http://www.red-bean.com/cvsutils/
+
+postprocess=
+case $1 in
+ --help) cat <<EOF
+Usage: $0 [-C SRCDIR] [DIR]
+
+Output a list of version-controlled files in DIR (default .), relative to
+SRCDIR (default .). SRCDIR must be the top directory of a checkout.
+
+Options:
+ --help print this help, then exit
+ --version print version number, then exit
+ -C SRCDIR change directory to SRCDIR before generating list
+
+Report bugs and patches to <bug-gnulib@gnu.org>.
+EOF
+ exit ;;
+
+ --version)
+ year=`echo "$scriptversion" | sed 's/[^0-9].*//'`
+ cat <<EOF
+vc-list-files $scriptversion
+Copyright (C) $year Free Software Foundation, Inc,
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.
+EOF
+ exit ;;
+
+ -C)
+ test "$2" = . || postprocess="| sed 's|^|$2/|'"
+ cd "$2" || exit 1
+ shift; shift ;;
+esac
+
+dir=
+case $# in
+ 0) ;;
+ 1) dir=$1 ;;
+ *) echo "$0: too many arguments" 1>&2
+ echo "Usage: $0 [-C srcdir] [DIR]" 1>&2; exit 1;;
+esac
+
+test "x$dir" = x && dir=.
+
+if test -d .git; then
+ test "x$dir" = x. \
+ && dir= sed_esc= \
+ || { dir="$dir/"; sed_esc=`echo "$dir"|env sed 's,\([\\/]\),\\\\\1,g'`; }
+ # Ignore git symlinks - either they point into the tree, in which case
+ # we don't need to visit the target twice, or they point somewhere
+ # else (often into a submodule), in which case the content does not
+ # belong to this package.
+ eval exec git ls-tree -r 'HEAD:"$dir"' \
+ \| sed -n '"s/^100[^ ]*./$sed_esc/p"' $postprocess
+elif test -d .hg; then
+ eval exec hg locate '"$dir/*"' $postprocess
+elif test -d .bzr; then
+ test "$postprocess" = '' && postprocess="| sed 's|^\./||'"
+ eval exec bzr ls --versioned '"$dir"' $postprocess
+elif test -d CVS; then
+ test "$postprocess" = '' && postprocess="| sed 's|^\./||'"
+ if test -x build-aux/cvsu; then
+ eval build-aux/cvsu --find --types=AFGM '"$dir"' $postprocess
+ elif (cvsu --help) >/dev/null 2>&1; then
+ eval cvsu --find --types=AFGM '"$dir"' $postprocess
+ else
+ eval awk -F/ \''{ \
+ if (!$1 && $3 !~ /^-/) { \
+ f=FILENAME; \
+ if (f ~ /CVS\/Entries$/) \
+ f = substr(f, 1, length(f)-11); \
+ print f $2; \
+ }}'\'' \
+ `find "$dir" -name Entries -print` /dev/null' $postprocess
+ fi
+else
+ echo "$0: Failed to determine type of version control used in `pwd`" 1>&2
+ exit 1
+fi
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-time-zone: "UTC"
+# time-stamp-end: "; # UTC"
+# End:
--- /dev/null
+old_NEWS_hash = d41d8cd98f00b204e9800998ecf8427e
dnl Builtins"), in particular on solaris it results in a literal "-n" in
dnl the output.
dnl
-AC_INIT(patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${PACKAGE}),[
-]),
+AC_INIT([GNU Guile],
patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${GUILE_VERSION}),[
]),
[bug-guile@gnu.org])
AC_PROG_CC
gl_EARLY
AC_PROG_CPP
+AC_PROG_SED
AC_PROG_AWK
dnl Gnulib.
AM_PATH_LISPDIR
+AC_DEFINE_UNQUOTED([HOST_TYPE], ["$host"],
+ [Define to the host's GNU triplet.])
+
#--------------------------------------------------------------------
#
# User options (after above tests that may set default CFLAGS etc.)
#
#--------------------------------------------------------------------
-GUILE_ERROR_ON_WARNING="yes"
+GUILE_ERROR_ON_WARNING="no"
AC_ARG_ENABLE(error-on-warning,
[ --enable-error-on-warning treat compile warnings as errors],
AC_ARG_ENABLE(debug-malloc,
[ --enable-debug-malloc include malloc debugging code],
if test "$enable_debug_malloc" = y || test "$enable_debug_malloc" = yes; then
- AC_DEFINE(GUILE_DEBUG_MALLOC, 1,
+ AC_DEFINE([GUILE_DEBUG_MALLOC], 1,
[Define this if you want to debug scm_must_malloc/realloc/free calls.])
fi)
fi
SCM_I_GSC_ENABLE_DEPRECATED=1
fi
-AC_DEFINE_UNQUOTED(SCM_WARN_DEPRECATED_DEFAULT, "$warn_default",
+AC_DEFINE_UNQUOTED([SCM_WARN_DEPRECATED_DEFAULT], "$warn_default",
[Define this to control the default warning level for deprecated features.])
AC_ARG_ENABLE(elisp,
AC_MSG_RESULT($use_64_calls)
case "$use_64_calls" in
y* )
- AC_DEFINE(GUILE_USE_64_CALLS, 1,
+ AC_DEFINE([GUILE_USE_64_CALLS], 1,
[Define to 1 in order to try to use "64" versions of system and library calls.])
;;
esac
if test "$enable_posix" = yes; then
AC_LIBOBJ([filesys])
AC_LIBOBJ([posix])
- AC_DEFINE(HAVE_POSIX, 1,
+ AC_DEFINE([HAVE_POSIX], 1,
[Define this if you want support for POSIX system calls in Guile.])
fi
if test "$enable_networking" = yes; then
AC_LIBOBJ([net_db])
AC_LIBOBJ([socket])
- AC_DEFINE(HAVE_NETWORKING, 1,
+ AC_DEFINE([HAVE_NETWORKING], 1,
[Define this if you want support for networking in Guile.])
fi
AC_CHECK_TYPE([uint64_t],[scm_stdint_has_uint64=1],,[#include <stdint.h>])
AC_CHECK_TYPE([intmax_t],[scm_stdint_has_intmax=1],,[#include <stdint.h>])
AC_CHECK_TYPE([uintmax_t],[scm_stdint_has_uintmax=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([intptr_t],[scm_stdint_has_intptr=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([uintptr_t],[scm_stdint_has_uintptr=1],,[#include <stdint.h>])
fi
# so we don't get confused by the cache (wish there was a better way
AC_CHECK_TYPE([uint64_t],[scm_inttypes_has_uint64=1],,[#include <inttypes.h>])
AC_CHECK_TYPE([intmax_t],[scm_inttypes_has_intmax=1],,[#include <inttypes.h>])
AC_CHECK_TYPE([uintmax_t],[scm_inttypes_has_uintmax=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([intptr_t],[scm_inttypes_has_intptr=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([uintptr_t],[scm_inttypes_has_uintptr=1],,[#include <inttypes.h>])
fi
# Try hard to find definitions for some required scm_t_*int* types.
fi
AC_SUBST([SCM_I_GSC_T_UINTMAX])
+### Required type scm_t_intptr
+###
+SCM_I_GSC_T_INTPTR=0
+if test "$scm_stdint_has_intptr"; then
+ SCM_I_GSC_T_INTPTR='"intptr_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_intptr"; then
+ SCM_I_GSC_T_INTPTR='"intptr_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_int" = "$ac_cv_sizeof_void_p"; then
+ SCM_I_GSC_T_INTPTR='"int"'
+elif test "$ac_cv_sizeof_long" = "$ac_cv_sizeof_void_p"; then
+ SCM_I_GSC_T_INTPTR='"long"'
+elif test "$ac_cv_sizeof_long_long" = "$ac_cv_sizeof_void_p"; then
+ SCM_I_GSC_T_INTPTR='"long long"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for `scm_t_intptr'.])
+fi
+AC_SUBST([SCM_I_GSC_T_INTPTR])
+
+### Required type scm_t_uintptr
+###
+SCM_I_GSC_T_UINTPTR=0
+if test "$scm_stdint_has_uintptr"; then
+ SCM_I_GSC_T_UINTPTR='"uintptr_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_uintptr"; then
+ SCM_I_GSC_T_UINTPTR='"uintptr_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_int" = "$ac_cv_sizeof_void_p"; then
+ SCM_I_GSC_T_UINTPTR='"unsigned int"'
+elif test "$ac_cv_sizeof_long" = "$ac_cv_sizeof_void_p"; then
+ SCM_I_GSC_T_UINTPTR='"unsigned long"'
+elif test "$ac_cv_sizeof_long_long" = "$ac_cv_sizeof_void_p"; then
+ SCM_I_GSC_T_UINTPTR='"unsigned long long"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for `scm_t_uintptr'.])
+fi
+AC_SUBST([SCM_I_GSC_T_UINTPTR])
+
AC_SUBST([SCM_I_GSC_NEEDS_STDINT_H])
AC_SUBST([SCM_I_GSC_NEEDS_INTTYPES_H])
# On MacOS X <sys/socklen.h> contains socklen_t, so must include that
# when testing.
AC_CHECK_TYPE(socklen_t, ,
- [AC_DEFINE_UNQUOTED(socklen_t, int,
+ [AC_DEFINE_UNQUOTED([socklen_t], int,
[Define to `int' if <sys/socket.h> does not define.])],
[#if HAVE_SYS_TYPES_H
#include <sys/types.h>
fi
if test "$enable_shared" = yes ; then
EXTRA_DEFS="-DSCM_IMPORT"
- AC_DEFINE(USE_DLL_IMPORT, 1,
+ AC_DEFINE([USE_DLL_IMPORT], 1,
[Define if you need additional CPP macros on Win32 platforms.])
fi
;;
# check this specifically, we need it for the timespec test below.
# sethostname - the function itself check because it's not in mingw,
# the DECL is checked because Solaris 10 doens't have in any header
-# xlocale.h - needed on Darwin for the `locale_t' API
# hstrerror - on Tru64 5.1b the symbol is available in libc but the
# declaration isn't anywhere.
# cuserid - on Tru64 5.1b the declaration is documented to be available
# only with `_XOPEN_SOURCE' or some such.
#
-AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h xlocale.h)
+AC_CHECK_HEADERS([crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h])
AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname)
AC_CHECK_DECLS([sethostname, hstrerror, cuserid])
# libraries already in that list.
#
AC_SEARCH_LIBS(crypt, crypt,
- [AC_DEFINE(HAVE_CRYPT,1,
+ [AC_DEFINE([HAVE_CRYPT],1,
[Define to 1 if you have the `crypt' function.])])
# When compiling with GCC on some OSs (Solaris, AIX), _Complex_I doesn't
]], [[
z = _Complex_I;
]])],
- [AC_DEFINE(GUILE_I,_Complex_I,[The imaginary unit (positive square root of -1).])
+ [AC_DEFINE([GUILE_I],_Complex_I,[The imaginary unit (positive square root of -1).])
AC_MSG_RESULT([_Complex_I])],
[AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#if HAVE_COMPLEX_H
]],[[
z = 1.0fi;
]])],
- [AC_DEFINE(GUILE_I,1.0fi)
+ [AC_DEFINE([GUILE_I],1.0fi)
AC_MSG_RESULT([1.0fi])],
[ac_cv_type_complex_double=no
AC_MSG_RESULT([not available])])])
[guile_cv_use_csqrt="yes, hopefully (cross-compiling)"])])
case $guile_cv_use_csqrt in
yes*)
- AC_DEFINE(HAVE_USABLE_CSQRT, 1, [Define to 1 if csqrt is bug-free])
+ AC_DEFINE([HAVE_USABLE_CSQRT], 1, [Define to 1 if csqrt is bug-free])
;;
esac
fi
AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README]))
dnl GNU libunistring is checked for by Gnulib's `libunistring' module.
+if test "x$LTLIBUNISTRING" != "x"; then
+ LIBS="$LTLIBUNISTRING $LIBS"
+else
+ AC_MSG_ERROR([GNU libunistring is required, please install it.])
+fi
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])
[guile_cv_func_usleep_return_type=int])])
case "$guile_cv_func_usleep_return_type" in
"void" )
- AC_DEFINE(USLEEP_RETURNS_VOID, 1,
+ AC_DEFINE([USLEEP_RETURNS_VOID], 1,
[Define if the system headers declare usleep to return void.])
;;
esac
AC_CHECK_HEADER(sys/un.h, have_sys_un_h=1)
if test -n "$have_sys_un_h" ; then
- AC_DEFINE(HAVE_UNIX_DOMAIN_SOCKETS, 1,
+ AC_DEFINE([HAVE_UNIX_DOMAIN_SOCKETS], 1,
[Define if the system supports Unix-domain (file-domain) sockets.])
fi
setprotoent getprotoent endprotoent dnl
setservent getservent endservent dnl
getnetbyaddr getnetbyname dnl
- inet_lnaof inet_makeaddr inet_netof hstrerror dnl
- inet_pton inet_ntop)
+ inet_lnaof inet_makeaddr inet_netof hstrerror)
# struct sockaddr field sin_len is only present on BSD systems.
# On 4.4BSD apparently a #define SIN_LEN exists, but on other BSD systems
AC_MSG_RESULT($guile_cv_have_libc_stack_end)
if test $guile_cv_have_libc_stack_end = yes; then
- AC_DEFINE(HAVE_LIBC_STACK_END, 1,
+ AC_DEFINE([HAVE_LIBC_STACK_END], 1,
[Define if you have the __libc_stack_end variable.])
fi
[guile_cv_have_h_errno=no])])
AC_MSG_RESULT($guile_cv_have_h_errno)
if test $guile_cv_have_h_errno = yes; then
- AC_DEFINE(HAVE_H_ERRNO, 1, [Define if h_errno is declared in netdb.h.])
+ AC_DEFINE([HAVE_H_ERRNO], 1, [Define if h_errno is declared in netdb.h.])
fi
AC_MSG_CHECKING(whether uint32_t is defined)
[guile_cv_have_uint32_t=no])])
AC_MSG_RESULT($guile_cv_have_uint32_t)
if test $guile_cv_have_uint32_t = yes; then
- AC_DEFINE(HAVE_UINT32_T, 1,
+ AC_DEFINE([HAVE_UINT32_T], 1,
[Define if uint32_t typedef is defined when netdb.h is include.])
fi
[guile_cv_have_ipv6=no])])
AC_MSG_RESULT($guile_cv_have_ipv6)
if test $guile_cv_have_ipv6 = yes; then
- AC_DEFINE(HAVE_IPV6, 1, [Define if you want support for IPv6.])
+ AC_DEFINE([HAVE_IPV6], 1, [Define if you want support for IPv6.])
fi
# included in rfc2553 but not in older implementations, e.g., glibc 2.1.3.
[guile_cv_have_sin6_scope_id=no])])
AC_MSG_RESULT($guile_cv_have_sin6_scope_id)
if test $guile_cv_have_sin6_scope_id = yes; then
- AC_DEFINE(HAVE_SIN6_SCOPE_ID, 1,
+ AC_DEFINE([HAVE_SIN6_SCOPE_ID], 1,
[Define this if your IPv6 has sin6_scope_id in sockaddr_in6 struct.])
fi
fi])dnl
AC_MSG_RESULT($guile_cv_localtime_cache)
if test $guile_cv_localtime_cache = yes; then
- AC_DEFINE(LOCALTIME_CACHE, 1, [Define if localtime caches the TZ setting.])
+ AC_DEFINE([LOCALTIME_CACHE], 1, [Define if localtime caches the TZ setting.])
fi
if test "$enable_regex" = yes; then
if test "$ac_cv_func_regcomp_norx" = yes ||
test "$ac_cv_func_regcomp_regex" = yes ||
test "$ac_cv_func_regcomp_rx" = yes; then
- AC_DEFINE(HAVE_REGCOMP, 1,
+ AC_DEFINE([HAVE_REGCOMP], 1,
[This is included as part of a workaround for a autoheader bug.])
fi
fi
volatile double x = 0.0;
int main () { return (isinf(x) != 0); }]]),
[AC_MSG_RESULT([yes])
- AC_DEFINE(HAVE_ISINF, 1,
+ AC_DEFINE([HAVE_ISINF], 1,
[Define to 1 if you have the `isinf' macro or function.])],
[AC_MSG_RESULT([no])])
AC_MSG_CHECKING([for isnan])
volatile double x = 0.0;
int main () { return (isnan(x) != 0); }]]),
[AC_MSG_RESULT([yes])
- AC_DEFINE(HAVE_ISNAN, 1,
+ AC_DEFINE([HAVE_ISNAN], 1,
[Define to 1 if you have the `isnan' macro or function.])],
[AC_MSG_RESULT([no])])
[],
[AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h)])
+#--------------------------------------------------------------------
+#
+# Boehm's GC library
+#
+#--------------------------------------------------------------------
+PKG_CHECK_MODULES([BDW_GC], [bdw-gc])
+
+CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
+LIBS="$BDW_GC_LIBS $LIBS"
+
+# `GC_do_blocking ()' is available in GC 7.1 but not declared.
+AC_CHECK_FUNCS([GC_do_blocking])
+AC_CHECK_DECL([GC_do_blocking],
+ [AC_DEFINE([HAVE_DECL_GC_DO_BLOCKING], [1],
+ [Define this if the `GC_do_blocking ()' function is declared])],
+ [],
+ [#include <gc/gc.h>])
+
+# `GC_fn_type' is not available in GC 7.1 and earlier.
+AC_CHECK_TYPE([GC_fn_type],
+ [AC_DEFINE([HAVE_GC_FN_TYPE], [1],
+ [Define this if the `GC_fn_type' type is available.])],
+ [],
+ [#include <gc/gc.h>])
+
+
AC_CHECK_SIZEOF(float)
if test "$ac_cv_sizeof_float" -le "$ac_cv_sizeof_long"; then
- AC_DEFINE(SCM_SINGLES, 1,
+ AC_DEFINE([SCM_SINGLES], 1,
[Define this if floats are the same size as longs.])
fi
[scm_cv_struct_linger="no"]))
AC_MSG_RESULT($scm_cv_struct_linger)
if test $scm_cv_struct_linger = yes; then
- AC_DEFINE(HAVE_STRUCT_LINGER, 1,
+ AC_DEFINE([HAVE_STRUCT_LINGER], 1,
[Define this if your system defines struct linger, for use with the
getsockopt and setsockopt system calls.])
fi
[scm_cv_struct_timespec="no"]))
AC_MSG_RESULT($scm_cv_struct_timespec)
if test $scm_cv_struct_timespec = yes; then
- AC_DEFINE(HAVE_STRUCT_TIMESPEC, 1,
+ AC_DEFINE([HAVE_STRUCT_TIMESPEC], 1,
[Define this if your system defines struct timespec via either <time.h> or <pthread.h>.])
fi
;;
"no" | "null")
SCM_I_GSC_USE_NULL_THREADS=1
+ SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS=0
with_threads="null-threads"
;;
* )
#endif
]])],
[works=yes
-AC_DEFINE(PTHREAD_ATTR_GETSTACK_WORKS, [1], [Define when pthread_att_get_stack works for the main thread])],
+AC_DEFINE([PTHREAD_ATTR_GETSTACK_WORKS], [1], [Define when pthread_att_get_stack works for the main thread])],
[works=no],
[])
CFLAGS="$old_CFLAGS"
AC_MSG_RESULT($works)
+GUILE_THREAD_LOCAL_STORAGE
+
fi # with_threads=pthreads
AC_SUBST(GUILE_FOR_BUILD)
## If we're using GCC, ask for aggressive warnings.
+GCC_CFLAGS=""
case "$GCC" in
yes )
## We had -Wstrict-prototypes in here for a bit, but Guile does too
## less than exasperating.
## -Wpointer-arith was here too, but something changed in gcc/glibc
## and it became equally exasperating (gcc 2.95 and/or glibc 2.1.2).
- GCC_CFLAGS="-Wall -Wmissing-prototypes"
+ POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \
+ -Wdeclaration-after-statement -Wundef \
+ -Wswitch-enum"
# Do this here so we don't screw up any of the tests above that might
# not be "warning free"
if test "${GUILE_ERROR_ON_WARNING}" = yes
then
- GCC_CFLAGS="${GCC_CFLAGS} -Werror"
+ POTENTIAL_GCC_CFLAGS="${POTENTIAL_GCC_CFLAGS} -Werror"
enable_compile_warnings=no
fi
+
+ for flag in $POTENTIAL_GCC_CFLAGS
+ do
+ gl_WARN_ADD([$flag], [GCC_CFLAGS])
+ done
;;
esac
AC_SUBST(GCC_CFLAGS)
+# Check for GNU ld's "-z relro".
+GUILE_GNU_LD_RELRO
+
+
## If we're creating a shared library (using libtool!), then we'll
## need to generate a list of .lo files corresponding to the .o files
## given in LIBOBJS. We'll call it LIBLOBJS.
dnl We need `sitedir' in `guile-1.8.pc'.
dnl Note: `sitedir' must be kept in sync with `GUILE_SITE_DIR' in `guile.m4'.
-pkgdatadir="$datadir/guile"
+pkgdatadir="$datadir/$PACKAGE_TARNAME"
sitedir="$pkgdatadir/site"
AC_SUBST([sitedir])
doc/tutorial/Makefile
emacs/Makefile
examples/Makefile
- lang/Makefile
libguile/Makefile
srfi/Makefile
guile-readline/Makefile
--- /dev/null
+<!--#include virtual="/server/header.html" -->
+<title>%%TITLE%% - GNU Project - Free Software Foundation (FSF)</title>
+<!--#include virtual="/server/banner.html" -->
+<h2>%%TITLE%%</h2>
+
+<!-- This document is in XML, and xhtml 1.0 -->
+<!-- Please make sure to properly nest your tags -->
+<!-- and ensure that your final document validates -->
+<!-- consistent with W3C xhtml 1.0 and CSS standards -->
+<!-- See validator.w3.org -->
+
+<address>Free Software Foundation</address>
+<address>last updated %%DATE%%</address>
+
+<p>This manual (%%PACKAGE%%) is available in the following formats:</p>
+
+<ul>
+<li><a href="%%PACKAGE%%.html">HTML
+ (%%HTML_MONO_SIZE%%K bytes)</a> - entirely on one web page.</li>
+<li><a href="html_node/index.html">HTML</a> - with one web page per
+ node.</li>
+%%IF HTML_SECTION%%
+<li><a href="html_section/index.html">HTML</a> - with one web page per
+ section.</li>
+%%ENDIF HTML_SECTION%%
+%%IF HTML_CHAPTER%%
+<li><a href="html_chapter/index.html">HTML</a> - with one web page per
+ chapter.</li>
+%%ENDIF HTML_CHAPTER%%
+<li><a href="%%PACKAGE%%.html.gz">HTML compressed
+ (%%HTML_MONO_GZ_SIZE%%K gzipped characters)</a> - entirely on
+ one web page.</li>
+<li><a href="%%PACKAGE%%.html_node.tar.gz">HTML compressed
+ (%%HTML_NODE_TGZ_SIZE%%K gzipped tar file)</a> -
+ with one web page per node.</li>
+%%IF HTML_SECTION%%
+<li><a href="%%PACKAGE%%.html_section.tar.gz">HTML compressed
+ (%%HTML_SECTION_TGZ_SIZE%%K gzipped tar file)</a> -
+ with one web page per section.</li>
+%%ENDIF HTML_SECTION%%
+%%IF HTML_CHAPTER%%
+<li><a href="%%PACKAGE%%.html_chapter.tar.gz">HTML compressed
+ (%%HTML_CHAPTER_TGZ_SIZE%%K gzipped tar file)</a> -
+ with one web page per chapter.</li>
+%%ENDIF HTML_CHAPTER%%
+<li><a href="%%PACKAGE%%.info.tar.gz">Info document
+ (%%INFO_TGZ_SIZE%%K bytes gzipped tar file)</a>.</li>
+<li><a href="%%PACKAGE%%.txt">ASCII text
+ (%%ASCII_SIZE%%K bytes)</a>.</li>
+<li><a href="%%PACKAGE%%.txt.gz">ASCII text compressed
+ (%%ASCII_GZ_SIZE%%K bytes gzipped)</a>.</li>
+<li><a href="%%PACKAGE%%.dvi.gz">TeX dvi file
+ (%%DVI_GZ_SIZE%%K bytes gzipped)</a>.</li>
+<li><a href="%%PACKAGE%%.ps.gz">PostScript file
+ (%%PS_GZ_SIZE%%K bytes gzipped)</a>.</li>
+<li><a href="%%PACKAGE%%.pdf">PDF file
+ (%%PDF_SIZE%%K bytes)</a>.</li>
+<li><a href="%%PACKAGE%%.texi.tar.gz">Texinfo source
+ (%%TEXI_TGZ_SIZE%%K bytes gzipped tar file).</a></li>
+</ul>
+
+<p>You can <a href="http://shop.fsf.org/">buy printed copies of
+some manuals</a> (among other items) from the Free Software Foundation;
+this helps support FSF activities.</p>
+
+<p>(This page generated by the <a href="%%SCRIPTURL%%">%%SCRIPTNAME%%
+script</a>.)</p>
+
+<!-- If needed, change the copyright block at the bottom. In general, -->
+<!-- all pages on the GNU web server should have the section about -->
+<!-- verbatim copying. Please do NOT remove this without talking -->
+<!-- with the webmasters first. -->
+<!-- Please make sure the copyright date is consistent with the document -->
+<!-- and that it is like this "2001, 2002" not this "2001-2002." -->
+</div><!-- for id="content", starts in the include above -->
+<!--#include virtual="/server/footer.html" -->
+<div id="footer">
+
+<p>
+Please send FSF & GNU inquiries to
+<a href="mailto:gnu@gnu.org"><gnu@gnu.org></a>.
+There are also <a href="/contact/">other ways to contact</a>
+the FSF.<br />
+Please send broken links and other corrections or suggestions to
+<a href="mailto:%%EMAIL%%"><%%EMAIL%%></a>.
+</p>
+
+<p>Copyright © 2009 Free Software Foundation, Inc.</p>
+
+<p>Verbatim copying and distribution of this entire article is
+permitted in any medium, provided this notice is preserved.</p>
+
+</div>
+</div>
+</body>
+</html>
requested, @code{open-file} throws an exception.
@end deffn
-\fmake-future
-@c snarfed from futures.c:89
-@deffn {Scheme Procedure} make-future thunk
-@deffnx {C Function} scm_make_future (thunk)
-Make a future evaluating THUNK.
-@end deffn
-
-\ffuture-ref
-@c snarfed from futures.c:221
-@deffn {Scheme Procedure} future-ref future
-@deffnx {C Function} scm_future_ref (future)
-If the future @var{x} has not been computed yet, compute and
-return @var{x}, otherwise just return the previously computed
-value.
-@end deffn
-
\fgc-live-object-stats
@c snarfed from gc.c:276
@deffn {Scheme Procedure} gc-live-object-stats
@lisp
(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1"
-(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}
-ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff
+(inet-ntop AF_INET6 (- (expt 2 128) 1))
+ @result{} "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff"
@end lisp
@end deffn
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@subsection Continuation Barriers
The non-local flow of control caused by continuations might sometimes
-not be wanted. You can use @code{with-continuation-barrier} etc to
-errect fences that continuations can not pass.
+not be wanted. You can use @code{with-continuation-barrier} to erect
+fences that continuations can not pass.
@deffn {Scheme Procedure} with-continuation-barrier proc
@deffnx {C Function} scm_with_continuation_barrier (proc)
* Complex:: Complex number operations.
* Arithmetic:: Arithmetic functions.
* Scientific:: Scientific functions.
-* Primitive Numerics:: Primitive numeric functions.
* Bitwise Operations:: Logical AND, OR, NOT, and so on.
* Random:: Random number generation.
@end menu
infinity, depending on the sign of the divided number.
The infinities are written @samp{+inf.0} and @samp{-inf.0},
-respectivly. This syntax is also recognized by @code{read} as an
+respectively. This syntax is also recognized by @code{read} as an
extension to the usual Scheme syntax.
Dividing zero by zero yields something that is not a number at all:
@end deftypefn
@deftypefn {C Function} SCM scm_from_double (double val)
-Return the @code{SCM} value that representats @var{val}. The returned
+Return the @code{SCM} value that represents @var{val}. The returned
value is inexact according to the predicate @code{inexact?}, but it
will be exactly equal to @var{val}.
@end deftypefn
@end deffn
-@node Primitive Numerics
-@subsubsection Primitive Numeric Functions
-
-Many of Guile's numeric procedures which accept any kind of numbers as
-arguments, including complex numbers, are implemented as Scheme
-procedures that use the following real number-based primitives. These
-primitives signal an error if they are called with complex arguments.
-
-@c begin (texi-doc-string "guile" "$abs")
-@deffn {Scheme Procedure} $abs x
-Return the absolute value of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$sqrt")
-@deffn {Scheme Procedure} $sqrt x
-Return the square root of @var{x}.
-@end deffn
-
-@deffn {Scheme Procedure} $expt x y
-@deffnx {C Function} scm_sys_expt (x, y)
-Return @var{x} raised to the power of @var{y}. This
-procedure does not accept complex arguments.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$sin")
-@deffn {Scheme Procedure} $sin x
-Return the sine of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$cos")
-@deffn {Scheme Procedure} $cos x
-Return the cosine of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$tan")
-@deffn {Scheme Procedure} $tan x
-Return the tangent of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$asin")
-@deffn {Scheme Procedure} $asin x
-Return the arcsine of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$acos")
-@deffn {Scheme Procedure} $acos x
-Return the arccosine of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$atan")
-@deffn {Scheme Procedure} $atan x
-Return the arctangent of @var{x} in the range @minus{}@math{PI/2} to
-@math{PI/2}.
-@end deffn
-
-@deffn {Scheme Procedure} $atan2 x y
-@deffnx {C Function} scm_sys_atan2 (x, y)
-Return the arc tangent of the two arguments @var{x} and
-@var{y}. This is similar to calculating the arc tangent of
-@var{x} / @var{y}, except that the signs of both arguments
-are used to determine the quadrant of the result. This
-procedure does not accept complex arguments.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$exp")
-@deffn {Scheme Procedure} $exp x
-Return e to the power of @var{x}, where e is the base of natural
-logarithms (2.71828@dots{}).
-@end deffn
-
-@c begin (texi-doc-string "guile" "$log")
-@deffn {Scheme Procedure} $log x
-Return the natural logarithm of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$sinh")
-@deffn {Scheme Procedure} $sinh x
-Return the hyperbolic sine of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$cosh")
-@deffn {Scheme Procedure} $cosh x
-Return the hyperbolic cosine of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$tanh")
-@deffn {Scheme Procedure} $tanh x
-Return the hyperbolic tangent of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$asinh")
-@deffn {Scheme Procedure} $asinh x
-Return the hyperbolic arcsine of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$acosh")
-@deffn {Scheme Procedure} $acosh x
-Return the hyperbolic arccosine of @var{x}.
-@end deffn
-
-@c begin (texi-doc-string "guile" "$atanh")
-@deffn {Scheme Procedure} $atanh x
-Return the hyperbolic arctangent of @var{x}.
-@end deffn
-
-C functions for the above are provided by the standard mathematics
-library. Naturally these expect and return @code{double} arguments
-(@pxref{Mathematics,,, libc, GNU C Library Reference Manual}).
-
-@multitable {xx} {Scheme Procedure} {C Function}
-@item @tab Scheme Procedure @tab C Function
-
-@item @tab @code{$abs} @tab @code{fabs}
-@item @tab @code{$sqrt} @tab @code{sqrt}
-@item @tab @code{$sin} @tab @code{sin}
-@item @tab @code{$cos} @tab @code{cos}
-@item @tab @code{$tan} @tab @code{tan}
-@item @tab @code{$asin} @tab @code{asin}
-@item @tab @code{$acos} @tab @code{acos}
-@item @tab @code{$atan} @tab @code{atan}
-@item @tab @code{$atan2} @tab @code{atan2}
-@item @tab @code{$exp} @tab @code{exp}
-@item @tab @code{$expt} @tab @code{pow}
-@item @tab @code{$log} @tab @code{log}
-@item @tab @code{$sinh} @tab @code{sinh}
-@item @tab @code{$cosh} @tab @code{cosh}
-@item @tab @code{$tanh} @tab @code{tanh}
-@item @tab @code{$asinh} @tab @code{asinh}
-@item @tab @code{$acosh} @tab @code{acosh}
-@item @tab @code{$atanh} @tab @code{atanh}
-@end multitable
-
-@code{asinh}, @code{acosh} and @code{atanh} are C99 standard but might
-not be available on older systems. Guile provides the following
-equivalents (on all systems).
-
-@deftypefn {C Function} double scm_asinh (double x)
-@deftypefnx {C Function} double scm_acosh (double x)
-@deftypefnx {C Function} double scm_atanh (double x)
-Return the hyperbolic arcsine, arccosine or arctangent of @var{x}
-respectively.
-@end deftypefn
-
-
@node Bitwise Operations
@subsubsection Bitwise Operations
@subsection Characters
@tpindex Characters
+In Scheme, there is a data type to describe a single character.
+
+Defining what exactly a character @emph{is} can be more complicated
+than it seems. Guile follows the advice of R6RS and uses The Unicode
+Standard to help define what a character is. So, for Guile, a
+character is anything in the Unicode Character Database.
+
+@cindex code point
+@cindex Unicode code point
+
+The Unicode Character Database is basically a table of characters
+indexed using integers called 'code points'. Valid code points are in
+the ranges 0 to @code{#xD7FF} inclusive or @code{#xE000} to
+@code{#x10FFFF} inclusive, which is about 1.1 million code points.
+
+@cindex designated code point
+@cindex code point, designated
+
+Any code point that has been assigned to a character or that has
+otherwise been given a meaning by Unicode is called a 'designated code
+point'. Most of the designated code points, about 200,000 of them,
+indicate characters, accents or other combining marks that modify
+other characters, symbols, whitespace, and control characters. Some
+are not characters but indicators that suggest how to format or
+display neighboring characters.
+
+@cindex reserved code point
+@cindex code point, reserved
+
+If a code point is not a designated code point -- if it has not been
+assigned to a character by The Unicode Standard -- it is a 'reserved
+code point', meaning that they are reserved for future use. Most of
+the code points, about 800,000, are 'reserved code points'.
+
+By convention, a Unicode code point is written as
+``U+XXXX'' where ``XXXX'' is a hexadecimal number. Please note that
+this convenient notation is not valid code. Guile does not interpret
+``U+XXXX'' as a character.
+
In Scheme, a character literal is written as @code{#\@var{name}} where
@var{name} is the name of the character that you want. Printable
characters have their usual single character name; for example,
-@code{#\a} is a lower case @code{a}.
+@code{#\a} is a lower case @code{a}.
-Most of the ``control characters'' (those below codepoint 32) in the
-@acronym{ASCII} character set, as well as the space, may be referred
-to by longer names: for example, @code{#\tab}, @code{#\esc},
-@code{#\stx}, and so on. The following table describes the
-@acronym{ASCII} names for each character.
+Some of the code points are 'combining characters' that are not meant
+to be printed by themselves but are instead meant to modify the
+appearance of the previous character. For combining characters, an
+alternate form of the character literal is @code{#\} followed by
+U+25CC (a small, dotted circle), followed by the combining character.
+This allows the combining character to be drawn on the circle, not on
+the backslash of @code{#\}.
+
+Many of the non-printing characters, such as whitespace characters and
+control characters, also have names.
+
+The most commonly used non-printing characters are space and
+newline. Their character names are @code{#\space} and
+@code{#\newline}. There are also names for all of the ``C0 control
+characters'' (those with code points below 32). The following table
+describes the names for each character.
@multitable @columnfractions .25 .25 .25 .25
@item 0 = @code{#\nul}
@tab 7 = @code{#\bel}
@item 8 = @code{#\bs}
@tab 9 = @code{#\ht}
- @tab 10 = @code{#\nl}
+ @tab 10 = @code{#\lf}
@tab 11 = @code{#\vt}
-@item 12 = @code{#\np}
+@item 12 = @code{#\ff}
@tab 13 = @code{#\cr}
@tab 14 = @code{#\so}
@tab 15 = @code{#\si}
@item 32 = @code{#\sp}
@end multitable
-The ``delete'' character (octal 177) may be referred to with the name
-@code{#\del}.
+The ``delete'' character (code point U+007F) may be referred to with the
+name @code{#\del}.
-Several characters have more than one name:
+One might note that the space character has two names --
+@code{#\space} and @code{#\sp} -- as does the newline character.
+Several other non-printing characters have more than one name, for the
+sake of compatibility with previous versions.
-@multitable {@code{#\backspace}} {Original}
-@item Alias @tab Original
-@item @code{#\space} @tab @code{#\sp}
-@item @code{#\newline} @tab @code{#\nl}
+@multitable {@code{#\backspace}} {Preferred}
+@item Alternate @tab Standard
+@item @code{#\sp} @tab @code{#\space}
+@item @code{#\nl} @tab @code{#\newline}
+@item @code{#\lf} @tab @code{#\newline}
@item @code{#\tab} @tab @code{#\ht}
@item @code{#\backspace} @tab @code{#\bs}
@item @code{#\return} @tab @code{#\cr}
-@item @code{#\page} @tab @code{#\np}
+@item @code{#\page} @tab @code{#\ff}
+@item @code{#\np} @tab @code{#\ff}
@item @code{#\null} @tab @code{#\nul}
@end multitable
+Characters may also be written using their code point values. They can
+be written with as an octal number, such as @code{#\10} for
+@code{#\bs} or @code{#\177} for @code{#\del}.
+
@rnindex char?
@deffn {Scheme Procedure} char? x
@deffnx {C Function} scm_char_p (x)
Return @code{#t} iff @var{x} is a character, else @code{#f}.
@end deffn
+Fundamentally, the character comparison operations below are
+numeric comparisons of the character's code points.
+
@rnindex char=?
@deffn {Scheme Procedure} char=? x y
-Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.
+Return @code{#t} iff code point of @var{x} is equal to the code point
+of @var{y}, else @code{#f}.
@end deffn
@rnindex char<?
@deffn {Scheme Procedure} char<? x y
-Return @code{#t} iff @var{x} is less than @var{y} in the @acronym{ASCII} sequence,
-else @code{#f}.
+Return @code{#t} iff the code point of @var{x} is less than the code
+point of @var{y}, else @code{#f}.
@end deffn
@rnindex char<=?
@deffn {Scheme Procedure} char<=? x y
-Return @code{#t} iff @var{x} is less than or equal to @var{y} in the
-@acronym{ASCII} sequence, else @code{#f}.
+Return @code{#t} iff the code point of @var{x} is less than or equal
+to the code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char>?
@deffn {Scheme Procedure} char>? x y
-Return @code{#t} iff @var{x} is greater than @var{y} in the @acronym{ASCII}
-sequence, else @code{#f}.
+Return @code{#t} iff the code point of @var{x} is greater than the
+code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char>=?
@deffn {Scheme Procedure} char>=? x y
-Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the
-@acronym{ASCII} sequence, else @code{#f}.
+Return @code{#t} iff the code point of @var{x} is greater than or
+equal to the code point of @var{y}, else @code{#f}.
@end deffn
+@cindex case folding
+
+Case-insensitive character comparisons use @emph{Unicode case
+folding}. In case folding comparisons, if a character is lowercase
+and has an uppercase form that can be expressed as a single character,
+it is converted to uppercase before comparison. All other characters
+undergo no conversion before the comparison occurs. This includes the
+German sharp S (Eszett) which is not uppercased before conversion
+because its uppercase form has two characters. Unicode case folding
+is language independent: it uses rules that are generally true, but,
+it cannot cover all cases for all languages.
+
@rnindex char-ci=?
@deffn {Scheme Procedure} char-ci=? x y
-Return @code{#t} iff @var{x} is the same character as @var{y} ignoring
-case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is the same
+as the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci<?
@deffn {Scheme Procedure} char-ci<? x y
-Return @code{#t} iff @var{x} is less than @var{y} in the @acronym{ASCII} sequence
-ignoring case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is less
+than the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci<=?
@deffn {Scheme Procedure} char-ci<=? x y
-Return @code{#t} iff @var{x} is less than or equal to @var{y} in the
-@acronym{ASCII} sequence ignoring case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is less
+than or equal to the case-folded code point of @var{y}, else
+@code{#f}.
@end deffn
@rnindex char-ci>?
@deffn {Scheme Procedure} char-ci>? x y
-Return @code{#t} iff @var{x} is greater than @var{y} in the @acronym{ASCII}
-sequence ignoring case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is greater
+than the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci>=?
@deffn {Scheme Procedure} char-ci>=? x y
-Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the
-@acronym{ASCII} sequence ignoring case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is greater
+than or equal to the case-folded code point of @var{y}, else
+@code{#f}.
@end deffn
@rnindex char-alphabetic?
@rnindex char->integer
@deffn {Scheme Procedure} char->integer chr
@deffnx {C Function} scm_char_to_integer (chr)
-Return the number corresponding to ordinal position of @var{chr} in the
-@acronym{ASCII} sequence.
+Return the code point of @var{chr}.
@end deffn
@rnindex integer->char
@deffn {Scheme Procedure} integer->char n
@deffnx {C Function} scm_integer_to_char (n)
-Return the character at position @var{n} in the @acronym{ASCII} sequence.
+Return the character that has code point @var{n}. The integer @var{n}
+must be a valid code point. Valid code points are in the ranges 0 to
+@code{#xD7FF} inclusive or @code{#xE000} to @code{#x10FFFF} inclusive.
@end deffn
@rnindex char-upcase
Character sets can be created, extended, tested for the membership of a
characters and be compared to other character sets.
-The Guile implementation of character sets currently deals only with
-8-bit characters. In the future, when Guile gets support for
-international character sets, this will change, but the functions
-provided here will always then be able to efficiently cope with very
-large character sets.
-
@menu
* Character Set Predicates/Comparison::
* Iterating Over Character Sets:: Enumerate charset elements.
If @var{error} is a true value, an error is signalled if the
specified range contains characters which are not contained in
the implemented character range. If @var{error} is @code{#f},
-these characters are silently left out of the resultung
+these characters are silently left out of the resulting
character set.
The characters in @var{base_cs} are added to the result, if
If @var{error} is a true value, an error is signalled if the
specified range contains characters which are not contained in
the implemented character range. If @var{error} is @code{#f},
-these characters are silently left out of the resultung
+these characters are silently left out of the resulting
character set.
The characters are added to @var{base_cs} and @var{base_cs} is
@deffn {Scheme Procedure} ->char-set x
@deffnx {C Function} scm_to_char_set (x)
-Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.
+Coerces x into a char-set. @var{x} may be a string, character or
+char-set. A string is converted to the set of its constituent
+characters; a character is converted to a singleton set; a char-set is
+returned as-is.
@end deffn
@c ===================================================================
Access the elements and other information of a character set with these
procedures.
+@deffn {Scheme Procedure} %char-set-dump cs
+Returns an association list containing debugging information
+for @var{cs}. The association list has the following entries.
+@table @code
+@item char-set
+The char-set itself
+@item len
+The number of groups of contiguous code points the char-set
+contains
+@item ranges
+A list of lists where each sublist is a range of code points
+and their associated characters
+@end table
+The return value of this function cannot be relied upon to be
+consistent between versions of Guile and should not be used in code.
+@end deffn
+
@deffn {Scheme Procedure} char-set-size cs
@deffnx {C Function} scm_char_set_size (cs)
Return the number of elements in character set @var{cs}.
Return the complement of the character set @var{cs}.
@end deffn
+Note that the complement of a character set is likely to contain many
+reserved code points (code points that are not associated with
+characters). It may be helpful to modify the output of
+@code{char-set-complement} by computing its intersection with the set
+of designated code points, @code{char-set:designated}.
+
@deffn {Scheme Procedure} char-set-union . rest
@deffnx {C Function} scm_char_set_union (rest)
Return the union of all argument character sets.
@cindex charset
@cindex locale
-Currently, the contents of these character sets are recomputed upon a
-successful @code{setlocale} call (@pxref{Locales}) in order to reflect
-the characters available in the current locale's codeset. For
-instance, @code{char-set:letter} contains 52 characters under an ASCII
-locale (e.g., the default @code{C} locale) and 117 characters under an
-ISO-8859-1 (``Latin-1'') locale.
+These character sets are locale independent and are not recomputed
+upon a @code{setlocale} call. They contain characters from the whole
+range of Unicode code points. For instance, @code{char-set:letter}
+contains about 94,000 characters.
@defvr {Scheme Variable} char-set:lower-case
@defvrx {C Variable} scm_char_set_lower_case
@defvr {Scheme Variable} char-set:title-case
@defvrx {C Variable} scm_char_set_title_case
-This is empty, because ASCII has no titlecase characters.
+All single characters that function as if they were an upper-case
+letter followed by a lower-case letter.
@end defvr
@defvr {Scheme Variable} char-set:letter
@defvrx {C Variable} scm_char_set_letter
-All letters, e.g. the union of @code{char-set:lower-case} and
-@code{char-set:upper-case}.
+All letters. This includes @code{char-set:lower-case},
+@code{char-set:upper-case}, @code{char-set:title-case}, and many
+letters that have no case at all. For example, Chinese and Japanese
+characters typically have no concept of case.
@end defvr
@defvr {Scheme Variable} char-set:digit
@defvr {Scheme Variable} char-set:blank
@defvrx {C Variable} scm_char_set_blank
-All horizontal whitespace characters, that is @code{#\space} and
-@code{#\tab}.
+All horizontal whitespace characters, which notably includes
+@code{#\space} and @code{#\tab}.
@end defvr
@defvr {Scheme Variable} char-set:iso-control
@defvrx {C Variable} scm_char_set_iso_control
-The ISO control characters with the codes 0--31 and 127.
+The ISO control characters are the C0 control characters (U+0000 to
+U+001F), delete (U+007F), and the C1 control characters (U+0080 to
+U+009F).
@end defvr
@defvr {Scheme Variable} char-set:punctuation
@defvrx {C Variable} scm_char_set_punctuation
-The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}}
+All punctuation characters, such as the characters
+@code{!"#%&'()*,-./:;?@@[\\]_@{@}}
@end defvr
@defvr {Scheme Variable} char-set:symbol
@defvrx {C Variable} scm_char_set_symbol
-The characters @code{$+<=>^`|~}.
+All symbol characters, such as the characters @code{$+<=>^`|~}.
@end defvr
@defvr {Scheme Variable} char-set:hex-digit
The empty character set.
@end defvr
+@defvr {Scheme Variable} char-set:designated
+@defvrx {C Variable} scm_char_set_designated
+This character set contains all designated code points. This includes
+all the code points to which Unicode has assigned a character or other
+meaning.
+@end defvr
+
@defvr {Scheme Variable} char-set:full
@defvrx {C Variable} scm_char_set_full
-This character set contains all possible characters.
+This character set contains all possible code points. This includes
+both designated and reserved code points.
@end defvr
@node Strings
When one of these two strings is modified, as with @code{string-set!},
their common memory does get copied so that each string has its own
-memory and modifying one does not accidently modify the other as well.
+memory and modifying one does not accidentally modify the other as well.
Thus, Guile's strings are `copy on write'; the actual copying of their
memory is delayed until one string is written to.
@item @nicode{\xHH}
Character code given by two hexadecimal digits. For example
@nicode{\x7f} for an ASCII DEL (127).
+
+@item @nicode{\uHHHH}
+Character code given by four hexadecimal digits. For example
+@nicode{\u0100} for a capital A with macron (U+0100).
+
+@item @nicode{\UHHHHHH}
+Character code given by six hexadecimal digits. For example
+@nicode{\U010402}.
@end table
@noindent
@deffnx {C Function} scm_string_trim (s, char_pred, start, end)
@deffnx {C Function} scm_string_trim_right (s, char_pred, start, end)
@deffnx {C Function} scm_string_trim_both (s, char_pred, start, end)
-Trim occurrances of @var{char_pred} from the ends of @var{s}.
+Trim occurrences of @var{char_pred} from the ends of @var{s}.
@code{string-trim} trims @var{char_pred} characters from the left
(start) of the string, @code{string-trim-right} trims them from the
predicates (@pxref{Characters}), but are defined on character sequences.
The first set is specified in R5RS and has names that end in @code{?}.
-The second set is specified in SRFI-13 and the names have no ending
-@code{?}. The predicates ending in @code{-ci} ignore the character case
-when comparing strings. @xref{Text Collation, the @code{(ice-9
+The second set is specified in SRFI-13 and the names have not ending
+@code{?}.
+
+The predicates ending in @code{-ci} ignore the character case
+when comparing strings. For now, case-insensitive comparison is done
+using the R5RS rules, where every lower-case character that has a
+single character upper-case form is converted to uppercase before
+comparison. See @xref{Text Collation, the @code{(ice-9
i18n)} module}, for locale-dependent string comparison.
@rnindex string=?
@deffn {Scheme Procedure} string-index s char_pred [start [end]]
@deffnx {C Function} scm_string_index (s, char_pred, start, end)
Search through the string @var{s} from left to right, returning
-the index of the first occurence of a character which
+the index of the first occurrence of a character which
@itemize @bullet
@item
equals @var{char_pred}, if it is character,
@item
-satisifies the predicate @var{char_pred}, if it is a procedure,
+satisfies the predicate @var{char_pred}, if it is a procedure,
@item
is in the set @var{char_pred}, if it is a character set.
@deffn {Scheme Procedure} string-rindex s char_pred [start [end]]
@deffnx {C Function} scm_string_rindex (s, char_pred, start, end)
Search through the string @var{s} from right to left, returning
-the index of the last occurence of a character which
+the index of the last occurrence of a character which
@itemize @bullet
@item
equals @var{char_pred}, if it is character,
@item
-satisifies the predicate @var{char_pred}, if it is a procedure,
+satisfies the predicate @var{char_pred}, if it is a procedure,
@item
is in the set if @var{char_pred} is a character set.
@deffn {Scheme Procedure} string-index-right s char_pred [start [end]]
@deffnx {C Function} scm_string_index_right (s, char_pred, start, end)
Search through the string @var{s} from right to left, returning
-the index of the last occurence of a character which
+the index of the last occurrence of a character which
@itemize @bullet
@item
equals @var{char_pred}, if it is character,
@item
-satisifies the predicate @var{char_pred}, if it is a procedure,
+satisfies the predicate @var{char_pred}, if it is a procedure,
@item
is in the set if @var{char_pred} is a character set.
@deffn {Scheme Procedure} string-skip s char_pred [start [end]]
@deffnx {C Function} scm_string_skip (s, char_pred, start, end)
Search through the string @var{s} from left to right, returning
-the index of the first occurence of a character which
+the index of the first occurrence of a character which
@itemize @bullet
@item
does not equal @var{char_pred}, if it is character,
@item
-does not satisify the predicate @var{char_pred}, if it is a
+does not satisfy the predicate @var{char_pred}, if it is a
procedure,
@item
@deffn {Scheme Procedure} string-skip-right s char_pred [start [end]]
@deffnx {C Function} scm_string_skip_right (s, char_pred, start, end)
Search through the string @var{s} from right to left, returning
-the index of the last occurence of a character which
+the index of the last occurrence of a character which
@itemize @bullet
@item
equals @var{char_pred}, if it is character,
@item
-satisifies the predicate @var{char_pred}, if it is a procedure.
+satisfies the predicate @var{char_pred}, if it is a procedure.
@item
is in the set @var{char_pred}, if it is a character set.
A good way to explore in detail what a Scheme procedure does is to set
a trap on it and then single step through what it does. To do this,
make and install a @code{<procedure-trap>} with the @code{debug-trap}
-behaviour from @code{(ice-9 debugging ice-9-debugger-extensions)}.
+behaviour from @code{(ice-9 debugger)}.
The following sample session illustrates this. It assumes that the
file @file{matrix.scm} defines a procedure @code{mkmatrix}, which is
@lisp
$ /usr/bin/guile -q
guile> (use-modules (ice-9 debugger)
- (ice-9 debugging ice-9-debugger-extensions)
(ice-9 debugging traps))
guile> (load "matrix.scm")
guile> (install-trap (make <procedure-trap>
Or you can use Guile's Emacs interface (GDS), by using the module
@code{(ice-9 gds-client)} instead of @code{(ice-9 debugger)} and
-@code{(ice-9 debugging ice-9-debugger-extensions)}, and changing
-@code{debug-trap} to @code{gds-debug-trap}. Then the stack and
-corresponding source locations are displayed in Emacs instead of on
-the Guile command line.
+changing @code{debug-trap} to @code{gds-debug-trap}. Then the stack and
+corresponding source locations are displayed in Emacs instead of on the
+Guile command line.
@node Profiling or Tracing a Procedure's Code
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
* Fly Evaluation:: Procedures for on the fly evaluation.
* Compilation:: How to compile Scheme files and procedures.
* Loading:: Loading Scheme code from file.
+* Character Encoding of Source Files:: Loading non-ASCII Scheme code from file.
* Delayed Evaluation:: Postponing evaluation until it is needed.
* Local Evaluation:: Evaluation in a local environment.
* Evaluator Behaviour:: Modifying Guile's evaluator.
More details on Guile scripting can be found in the scripting section
(@pxref{Guile Scripting}).
+@cindex R6RS block comments
+@cindex SRFI-30 block comments
+Similarly, Guile (starting from version 2.0) supports nested block
+comments as specified by R6RS and
+@url{http://srfi.schemers.org/srfi-30/srfi-30.html, SRFI-30}:
+
+@lisp
+(+ #| this is a #| nested |# block comment |# 2)
+@result{} 3
+@end lisp
+
+For backward compatibility, this syntax can be overridden with
+@code{read-hash-extend} (@pxref{Reader Extensions,
+@code{read-hash-extend}}).
+
+There is one special case where the contents of a comment can actually
+affect the interpretation of code. When a character encoding
+declaration, such as @code{coding: utf-8} appears in one of the first
+few lines of a source file, it indicates to Guile's default reader
+that this source code file is not ASCII. For details see @ref{Character
+Encoding of Source Files}.
@node Case Sensitivity
@subsubsection Case Sensitivity
@code{SCM}.
@end deftypefn
-@deffn {Scheme Procedure} primitive-load-path filename
+@deffn {Scheme Procedure} primitive-load-path filename [exception-on-not-found]
@deffnx {C Function} scm_primitive_load_path (filename)
Search @code{%load-path} for the file named @var{filename} and
load it into the top-level environment. If @var{filename} is a
relative pathname and is not found in the list of search paths,
an error is signalled. Preferentially loads a compiled version of the
file, if it is available and up-to-date.
+
+By default or if @var{exception-on-not-found} is true, an exception is
+raised if @var{filename} is not found. If @var{exception-on-not-found}
+is @code{#f} and @var{filename} is not found, no exception is raised and
+@code{#f} is returned. For compatibility with Guile 1.8 and earlier,
+the C function takes only one argument, which can be either a string
+(the file name) or an argument list.
@end deffn
@deffn {Scheme Procedure} %search-load-path filename
independent value in each dynamic root and should be read and set using
@code{fluid-ref} and @code{fluid-set!} (@pxref{Fluids and Dynamic
States}).
+
+Changing @code{current-reader} is typically useful to introduce local
+syntactic changes, such that code following the @code{fluid-set!} call
+is read using the newly installed reader. The @code{current-reader}
+change should take place at evaluation time when the code is evaluated,
+or at compilation time when the code is compiled:
+
+@findex eval-when
+@example
+(eval-when (compile eval)
+ (fluid-set! current-reader my-own-reader))
+@end example
+
+The @code{eval-when} form above ensures that the @code{current-reader}
+change occurs at the right time.
@end defvar
@defvar %load-hook
list @code{("" ".scm")}.
@end defvar
+@node Character Encoding of Source Files
+@subsection Character Encoding of Source Files
+
+@cindex source file encoding
+@cindex primitive-load
+@cindex load
+Scheme source code files are usually encoded in ASCII, but, the
+built-in reader can interpret other character encodings. The
+procedure @code{primitive-load}, and by extension the functions that
+call it, such as @code{load}, first scan the top 500 characters of the
+file for a coding declaration.
+
+A coding declaration has the form @code{coding: XXXXXX}, where
+@code{XXXXXX} is the name of a character encoding in which the source
+code file has been encoded. The coding declaration must appear in a
+scheme comment. It can either be a semicolon-initiated comment or a block
+@code{#!} comment.
+
+The name of the character encoding in the coding declaration is
+typically lower case and containing only letters, numbers, and hyphens,
+as recognized by @code{set-port-encoding!} (@pxref{Ports,
+@code{set-port-encoding!}}). Common examples of character encoding
+names are @code{utf-8} and @code{iso-8859-1},
+@url{http://www.iana.org/assignments/character-sets, as defined by
+IANA}. Thus, the coding declaration is mostly compatible with Emacs.
+
+However, there are some differences in encoding names recognized by
+Emacs and encoding names defined by IANA, the latter being essentially a
+subset of the former. For instance, @code{latin-1} is a valid encoding
+name for Emacs, but it's not according to the IANA standard, which Guile
+follows; instead, you should use @code{iso-8859-1}, which is both
+understood by Emacs and dubbed by IANA (IANA writes it uppercase but
+Emacs wants it lowercase and Guile is case insensitive.)
+
+For source code, only a subset of all possible character encodings can
+be interpreted by the built-in source code reader. Only those
+character encodings in which ASCII text appears unmodified can be
+used. This includes @code{UTF-8} and @code{ISO-8859-1} through
+@code{ISO-8859-15}. The multi-byte character encodings @code{UTF-16}
+and @code{UTF-32} may not be used because they are not compatible with
+ASCII.
+
+@cindex read
+@cindex encoding
+@cindex port encoding
+@findex set-port-encoding!
+There might be a scenario in which one would want to read non-ASCII
+code from a port, such as with the function @code{read}, instead of
+with @code{load}. If the port's character encoding is the same as the
+encoding of the code to be read by the port, not other special
+handling is necessary. The port will automatically do the character
+encoding conversion. The functions @code{setlocale} or by
+@code{set-port-encoding!} are used to set port encodings
+(@pxref{Ports}).
+
+If a port is used to read code of unknown character encoding, it can
+accomplish this in three steps. First, the character encoding of the
+port should be set to ISO-8859-1 using @code{set-port-encoding!}.
+Then, the procedure @code{file-encoding}, described below, is used to
+scan for a coding declaration when reading from the port. As a side
+effect, it rewinds the port after its scan is complete. After that,
+the port's character encoding should be set to the encoding returned
+by @code{file-encoding}, if any, again by using
+@code{set-port-encoding!}. Then the code can be read as normal.
+
+@deffn {Scheme Procedure} file-encoding port
+@deffnx {C Function} scm_file_encoding port
+Scan the port for an Emacs-like character coding declaration near the
+top of the contents of a port with random-accessible contents
+(@pxref{Recognize Coding, how Emacs recognizes file encoding,, emacs,
+The GNU Emacs Reference Manual}). The coding declaration is of the form
+@code{coding: XXXXX} and must appear in a Scheme comment. Return a
+string containing the character encoding of the file if a declaration
+was found, or @code{#f} otherwise. The port is rewound.
+@end deffn
+
@node Delayed Evaluation
@subsection Delayed Evaluation
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
(use-modules (ice-9 i18n))
@end example
-@cindex libguile-i18n-v-@value{LIBGUILE_I18N_MAJOR}
-
-C programs can use the C functions corresponding to the procedures of
-this module by including @code{<libguile/i18n.h>} and by linking
-against @code{libguile-i18n-v-@value{LIBGUILE_I18N_MAJOR}}.
-
@cindex cultural conventions
The @code{(ice-9 i18n)} module provides procedures to manipulate text
Ports are garbage collected in the usual way (@pxref{Memory
Management}), and will be closed at that time if not already closed.
-In this case any errors occuring in the close will not be reported.
+In this case any errors occurring in the close will not be reported.
Usually a program will want to explicitly close so as to be sure all
its operations have been successful. Of course if a program has
abandoned something due to an error or other condition then closing
available, so files bigger than 2 Gbytes (@math{2^31} bytes) can be
read and written on a 32-bit system.
+Each port has an associated character encoding that controls how bytes
+read from the port are converted to characters and string and controls
+how characters and strings written to the port are converted to bytes.
+When ports are created, they inherit their character encoding from the
+current locale, but, that can be modified after the port is created.
+
+Each port also has an associated conversion strategy: what to do when
+a Guile character can't be converted to the port's encoded character
+representation for output. There are three possible strategies: to
+raise an error, to replace the character with a hex escape, or to
+replace the character with a substitute character.
+
@rnindex input-port?
@deffn {Scheme Procedure} input-port? x
@deffnx {C Function} scm_input_port_p (x)
@var{x}))}.
@end deffn
+@deffn {Scheme Procedure} set-port-encoding! port enc
+@deffnx {C Function} scm_set_port_encoding_x (port, enc)
+Sets the character encoding that will be used to interpret all port I/O.
+@var{enc} is a string containing the name of an encoding. Valid
+encoding names are those
+@url{http://www.iana.org/assignments/character-sets, defined by IANA}.
+@end deffn
+
+@defvr {Scheme Variable} %default-port-encoding
+A fluid containing containing @code{#f} or the name of the encoding to
+be used by default for newly created ports (@pxref{Fluids and Dynamic
+States}). The value @code{#f} is equivalent to @code{"ISO-8859-1"}.
+
+New ports are created with the encoding appropriate for the current
+locale if @code{setlocale} has been called or the value specified by
+this fluid otherwise.
+@end defvr
+
+@deffn {Scheme Procedure} port-encoding port
+@deffnx {C Function} scm_port_encoding
+Returns, as a string, the character encoding that @var{port} uses to
+interpret its input and output.
+@end deffn
+
+@deffn {Scheme Procedure} set-port-conversion-strategy! port sym
+@deffnx {C Function} scm_set_port_conversion_strategy_x (port, sym)
+Sets the behavior of the interpreter when outputting a character that
+is not representable in the port's current encoding. @var{sym} can be
+either @code{'error}, @code{'substitute}, or @code{'escape}. If it is
+@code{'error}, an error will be thrown when an nonconvertible character
+is encountered. If it is @code{'substitute}, then nonconvertible
+characters will be replaced with approximate characters, or with
+question marks if no approximately correct character is available. If
+it is @code{'escape}, it will appear as a hex escape when output.
+
+If @var{port} is an open port, the conversion error behavior
+is set for that port. If it is @code{#f}, it is set as the
+default behavior for any future ports that get created in
+this thread.
+@end deffn
+
+@deffn {Scheme Procedure} port-conversion-strategy port
+@deffnx {C Function} scm_port_conversion_strategy (port)
+Returns the behavior of the port when outputting a character that is
+not representable in the port's current encoding. It returns the
+symbol @code{error} if unrepresentable characters should cause
+exceptions, @code{substitute} if the port should try to replace
+unrepresentable characters with question marks or approximate
+characters, or @code{escape} if unrepresentable characters should be
+converted to string escapes.
+
+If @var{port} is @code{#f}, then the current default behavior will be
+returned. New ports will have this default behavior when they are
+created.
+@end deffn
+
+
@node Reading
@subsection Reading
The output is designed to be machine readable, and can be read back
with @code{read} (@pxref{Reading}). Strings are printed in
-doublequotes, with escapes if necessary, and characters are printed in
+double quotes, with escapes if necessary, and characters are printed in
@samp{#\} notation.
@end deffn
output port if not given.
The output is designed for human readability, it differs from
-@code{write} in that strings are printed without doublequotes and
+@code{write} in that strings are printed without double quotes and
escapes, and characters are printed as per @code{write-char}, not in
@samp{#\} form.
@end deffn
@end lisp
@end deffn
-Some of the abovementioned I/O functions rely on the following C
+Some of the aforementioned I/O functions rely on the following C
primitives. These will mainly be of interest to people hacking Guile
internals.
Open @var{filename} for input or output, and call @code{(@var{proc}
port)} with the resulting port. Return the value returned by
@var{proc}. @var{filename} is opened as per @code{open-input-file} or
-@code{open-output-file} respectively, and an error is signalled if it
+@code{open-output-file} respectively, and an error is signaled if it
cannot be opened.
When @var{proc} returns, the port is closed. If @var{proc} does not
-return (eg.@: if it throws an error), then the port might not be
+return (e.g.@: if it throws an error), then the port might not be
closed automatically, though it will be garbage collected in the usual
way if not otherwise referenced.
@end deffn
@code{current-output-port}, or @code{current-error-port}. Return the
value returned by @var{thunk}. @var{filename} is opened as per
@code{open-input-file} or @code{open-output-file} respectively, and an
-error is signalled if it cannot be opened.
+error is signaled if it cannot be opened.
When @var{thunk} returns, the port is closed and the previous setting
of the respective current port is restored.
The following allow string ports to be opened by analogy to R4R*
file port facilities:
+With string ports, the port-encoding is treated differently than other
+types of ports. When string ports are created, they do not inherit a
+character encoding from the current locale. They are given a
+default locale that allows them to handle all valid string characters.
+Typically one should not modify a string port's character encoding
+away from its default.
+
@deffn {Scheme Procedure} call-with-output-string proc
@deffnx {C Function} scm_call_with_output_string (proc)
Calls the one-argument procedure @var{proc} with a newly created output
@node Port Implementation
@subsubsection Port Implementation
-@cindex Port implemenation
+@cindex Port implementation
This section describes how to implement a new port type in C.
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
the object remains protected until it has been unprotected as many times
as it was protected. It is an error to unprotect an object more times
than it has been protected. Returns the SCM object it was passed.
+
+Note that storing @var{obj} in a C global variable has the same
+effect@footnote{In Guile up to version 1.8, C global variables were not
+scanned by the garbage collector; hence, @code{scm_gc_protect_object}
+was the only way in C to prevent a Scheme object from being freed.}.
@end deftypefn
@deftypefn {C Function} SCM scm_gc_unprotect_object (SCM @var{obj})
@node Memory Blocks
@subsection Memory Blocks
+@cindex automatically-managed memory
+@cindex GC-managed memory
+@cindex conservative garbage collection
+
In C programs, dynamic management of memory blocks is normally done
with the functions malloc, realloc, and free. Guile has additional
functions for dynamic memory allocation that are integrated into the
garbage collector and the error reporting system.
Memory blocks that are associated with Scheme objects (for example a
-smob) should be allocated and freed with @code{scm_gc_malloc} and
-@code{scm_gc_free}. The function @code{scm_gc_malloc} will either
-return a valid pointer or signal an error. It will also assume that
-the new memory can be freed by a garbage collection. The garbage
-collector uses this information to decide when to try to actually
-collect some garbage. Memory blocks allocated with
-@code{scm_gc_malloc} must be freed with @code{scm_gc_free}.
+smob) should be allocated with @code{scm_gc_malloc} or
+@code{scm_gc_malloc_pointerless}. These two functions will either
+return a valid pointer or signal an error. Memory blocks allocated this
+way can be freed with @code{scm_gc_free}; however, this is not strictly
+needed: memory allocated with @code{scm_gc_malloc} or
+@code{scm_gc_malloc_pointerless} is automatically reclaimed when the
+garbage collector no longer sees any live reference to it@footnote{In
+Guile up to version 1.8, memory allocated with @code{scm_gc_malloc}
+@emph{had} to be freed with @code{scm_gc_free}.}.
+
+Memory allocated with @code{scm_gc_malloc} is scanned for live pointers.
+This means that if @code{scm_gc_malloc}-allocated memory contains a
+pointer to some other part of the memory, the garbage collector notices
+it and prevents it from being reclaimed@footnote{In Guile up to 1.8,
+memory allocated with @code{scm_gc_malloc} was @emph{not} scanned.
+Consequently, the GC had to be told explicitly about pointers to live
+objects contained in the memory block, e.g., @i{via} SMOB mark functions
+(@pxref{Smobs, @code{scm_set_smob_mark}})}. Conversely, memory
+allocated with @code{scm_gc_malloc_pointerless} is assumed to be
+``pointer-less'' and is not scanned.
For memory that is not associated with a Scheme object, you can use
@code{scm_malloc} instead of @code{malloc}. Like
@code{scm_gc_malloc}, it will either return a valid pointer or signal
an error. However, it will not assume that the new memory block can
-be freed by a garbage collection. The memory can be freed with
-@code{free}.
+be freed by a garbage collection. The memory must be explicitly freed
+with @code{free}.
There is also @code{scm_gc_realloc} and @code{scm_realloc}, to be used
in place of @code{realloc} when appropriate, and @code{scm_gc_calloc}
and @code{scm_calloc}, to be used in place of @code{calloc} when
appropriate.
-The function @code{scm_dynwind_free} can be useful when memory should
-be freed when a dynwind context, @xref{Dynamic Wind}.
-
-For really specialized needs, take at look at
-@code{scm_gc_register_collectable_memory} and
-@code{scm_gc_unregister_collectable_memory}.
+The function @code{scm_dynwind_free} can be useful when memory should be
+freed with libc's @code{free} when leaving a dynwind context,
+@xref{Dynamic Wind}.
@deftypefn {C Function} {void *} scm_malloc (size_t @var{size})
@deftypefnx {C Function} {void *} scm_calloc (size_t @var{size})
+@deftypefn {C Function} {void *} scm_gc_malloc (size_t @var{size}, const char *@var{what})
+@deftypefnx {C Function} {void *} scm_gc_malloc_pointerless (size_t @var{size}, const char *@var{what})
+@deftypefnx {C Function} {void *} scm_gc_realloc (void *@var{mem}, size_t @var{old_size}, size_t @var{new_size}, const char *@var{what});
+@deftypefnx {C Function} {void *} scm_gc_calloc (size_t @var{size}, const char *@var{what})
+Allocate @var{size} bytes of automatically-managed memory. The memory
+is automatically freed when no longer referenced from any live memory
+block.
+
+Memory allocated with @code{scm_gc_malloc} or @code{scm_gc_calloc} is
+scanned for pointers. Memory allocated by
+@code{scm_gc_malloc_pointerless} is not scanned.
+
+The @code{scm_gc_realloc} call preserves the ``pointerlessness'' of the
+memory area pointed to by @var{mem}. Note that you need to pass the old
+size of a reallocated memory block as well. See below for a motivation.
+@end deftypefn
+
+
+@deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what})
+Explicitly free the memory block pointed to by @var{mem}, which was
+previously allocated by one of the above @code{scm_gc} functions.
+
+Note that you need to explicitly pass the @var{size} parameter. This
+is done since it should normally be easy to provide this parameter
+(for memory that is associated with GC controlled objects) and help keep
+the memory management overhead very low. However, in Guile 2.x,
+@var{size} is always ignored.
+@end deftypefn
+
+
@deftypefn {C Function} void scm_gc_register_collectable_memory (void *@var{mem}, size_t @var{size}, const char *@var{what})
Informs the GC that the memory at @var{mem} of size @var{size} can
potentially be freed during a GC. That is, announce that @var{mem} is
much bytes of memory are associated with GC controlled objects and the
memory system figures this into its decisions when to run a GC.
-@var{mem} does not need to come from @code{scm_malloc}. You can only
-call this function once for every memory block.
-
The @var{what} argument is used for statistical purposes. It should
describe the type of object that the memory will be used for so that
users can identify just what strange objects are eating up their
memory.
+
+In Guile 2.x, this function has no effect.
@end deftypefn
@deftypefn {C Function} void scm_gc_unregister_collectable_memory (void *@var{mem}, size_t @var{size})
a call to @code{scm_gc_unregister_collectable_memory}. If you don't do
this, the GC might have a wrong impression of what is going on and run
much less efficiently than it could.
-@end deftypefn
-@deftypefn {C Function} {void *} scm_gc_malloc (size_t @var{size}, const char *@var{what})
-@deftypefnx {C Function} {void *} scm_gc_realloc (void *@var{mem}, size_t @var{old_size}, size_t @var{new_size}, const char *@var{what});
-@deftypefnx {C Function} {void *} scm_gc_calloc (size_t @var{size}, const char *@var{what})
-Like @code{scm_malloc}, @code{scm_realloc} or @code{scm_calloc}, but
-also call @code{scm_gc_register_collectable_memory}. Note that you
-need to pass the old size of a reallocated memory block as well. See
-below for a motivation.
+In Guile 2.x, this function has no effect.
@end deftypefn
-@deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what})
-Like @code{free}, but also call @code{scm_gc_unregister_collectable_memory}.
-
-Note that you need to explicitly pass the @var{size} parameter. This
-is done since it should normally be easy to provide this parameter
-(for memory that is associated with GC controlled objects) and this
-frees us from tracking this value in the GC itself, which will keep
-the memory management overhead very low.
-@end deftypefn
-
@deftypefn {C Function} void scm_frame_free (void *mem)
Equivalent to @code{scm_frame_unwind_handler (free, @var{mem},
SCM_F_WIND_EXPLICITLY)}. That is, the memory block at @var{mem} will
@var{what} is the second argument to @code{scm_gc_malloc},
@var{n} is the number of objects of that type currently
allocated.
+
+This function is only available if the @code{GUILE_DEBUG_MALLOC}
+preprocessor macro was defined when Guile was compiled.
@end deffn
Read hash extension @code{#,()} (@pxref{SRFI-10}).
@item (srfi srfi-11)
-Multiple-value handling with @code{let-values} and @code{let-values*}
+Multiple-value handling with @code{let-values} and @code{let*-values}
(@pxref{SRFI-11}).
@item (srfi srfi-13)
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
is returned.
@end deffn
-@deffn {Scheme Procedure} search-path path filename [extensions]
-@deffnx {C Function} scm_search_path (path, filename, extensions)
+@deffn {Scheme Procedure} search-path path filename [extensions [require-exts?]]
+@deffnx {C Function} scm_search_path (path, filename, rest)
Search @var{path} for a directory containing a file named
@var{filename}. The file must be readable, and not a directory.
If we find one, return its full filename; otherwise, return
@code{#f}. If @var{filename} is absolute, return it unchanged.
If given, @var{extensions} is a list of strings; for each
directory in @var{path}, we search for @var{filename}
-concatenated with each @var{extension}.
+concatenated with each @var{extension}. If @var{require-exts?}
+is true, require that the returned file name have one of the
+given extensions; if @var{require-exts?} is not given, it
+defaults to @code{#f}.
+
+For compatibility with Guile 1.8 and earlier, the C function takes only
+three arguments
@end deffn
@defvar %guile-build-info
before a build guarantees up-to-date values for that build.
@end defvar
+@cindex GNU triplet
+@cindex canonical host type
+
+@defvar %host-type
+The canonical host type (GNU triplet) of the host Guile was configured
+for, e.g., @code{"x86_64-unknown-linux-gnu"} (@pxref{Canonicalizing,,,
+autoconf, The GNU Autoconf Manual}).
+@end defvar
@node Feature Tracking
@subsection Feature Tracking
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
* Primitive Procedures:: Procedures defined in C.
* Compiled Procedures:: Scheme procedures can be compiled.
* Optional Arguments:: Handling keyword, optional and rest arguments.
+* Case-lambda:: One function, multiple arities.
* Procedure Properties:: Procedure properties and meta-information.
* Procedures with Setters:: Procedures with setters.
* Macros:: Lisp style macro definitions.
@subsection Lambda: Basic Procedure Creation
@cindex lambda
-@c FIXME::martin: Review me!
-
A @code{lambda} expression evaluates to a procedure. The environment
which is in effect when a @code{lambda} expression is evaluated is
enclosed in the newly created procedure, this is referred to as a
@node Compiled Procedures
@subsection Compiled Procedures
-Procedures that were created when loading a compiled file are
-themselves compiled. (In contrast, procedures that are defined by
-loading a Scheme source file are interpreted, and often not as fast as
-compiled procedures.)
+In Guile, procedures can be executed by directly interpreting their
+source code. Scheme source code is a set of nested lists, after all,
+with each list representing a procedure call.
+
+Most procedures are compiled, however. This means that Guile has done
+some pre-computation on the procedure, to determine what it will need
+to do each time the procedure runs. Compiled procedures run faster
+than interpreted procedures.
-Loading compiled files is the normal way that compiled procedures come
-to being, though procedures can be compiled at runtime as well.
-@xref{Read/Load/Eval/Compile}, for more information on runtime
-compilation.
+Loading files is the normal way that compiled procedures come to
+being. If Guile sees that a file is uncompiled, or that its compiled
+file is out of date, it will attempt to compile the file when it is
+loaded, and save the result to disk. Procedures can be compiled at
+runtime as well. @xref{Read/Load/Eval/Compile}, for more information
+on runtime compilation.
Compiled procedures, also known as @dfn{programs}, respond all
procedures that operate on procedures. In addition, there are a few
was unnecessary.
@end deffn
-@deffn {Scheme Procedure} program-external program
-@deffnx {C Function} scm_program_external (program)
-Returns the set of heap-allocated variables that this program captures
-in its closure, as a list. If a closure is code with data, you can get
-the code from @code{program-bytecode}, and the data via
-@code{program-external}.
+@deffn {Scheme Procedure} program-free-variables program
+@deffnx {C Function} scm_program_free_variables (program)
+Returns the set of free variables that this program captures in its
+closure, as a vector. If a closure is code with data, you can get the
+code from @code{program-objcode}, and the data via
+@code{program-free-variables}.
+
+Some of the values captured are actually in variable ``boxes''.
+@xref{Variables and the VM}, for more information.
Users must not modify the returned value unless they think they're
really clever.
@end deffn
-@deffn {Scheme Procedure} program-external-set! program external
-@deffnx {C Function} scm_program_external_set_x (program, external)
-Set @var{external} as the set of closure variables on @var{program}.
-
-The Guile maintainers will not be held responsible for side effects of
-calling this function, including but not limited to replacement of
-shampoo with hair dye, and a slight salty taste in tomorrow's dinner.
-@end deffn
-
-@deffn {Scheme Procedure} program-arity program
-@deffnx {C Function} scm_program_arity (program)
-@deffnx {Scheme Procedure} arity:nargs arity
-@deffnx {Scheme Procedure} arity:nrest arity
-@deffnx {Scheme Procedure} arity:nlocs arity
-@deffnx {Scheme Procedure} arity:nexts arity
-Accessors for a representation of the ``arity'' of a program.
-
-@code{nargs} is the number of arguments to the procedure, and
-@code{nrest} will be non-zero if the last argument is a rest argument.
-
-The other two accessors determine the number of local and external
-(heap-allocated) variables that this procedure will need to have
-allocated.
-@end deffn
-
@deffn {Scheme Procedure} program-meta program
-@deffnx scm_program_meta (program)
+@deffnx {C Function} scm_program_meta (program)
Return the metadata thunk of @var{program}, or @code{#f} if it has no
metadata.
When called, a metadata thunk returns a list of the following form:
-@code{(@var{bindings} @var{sources} . @var{properties})}. The format
+@code{(@var{bindings} @var{sources} @var{arities} . @var{properties})}. The format
of each of these elements is discussed below.
@end deffn
@deffn {Scheme Procedure} program-bindings program
-@deffnx {Scheme Procedure} make-binding name extp index start end
+@deffnx {Scheme Procedure} make-binding name boxed? index start end
@deffnx {Scheme Procedure} binding:name binding
-@deffnx {Scheme Procedure} binding:extp binding
+@deffnx {Scheme Procedure} binding:boxed? binding
@deffnx {Scheme Procedure} binding:index binding
@deffnx {Scheme Procedure} binding:start binding
@deffnx {Scheme Procedure} binding:end binding
Bindings declare names and liveness extents for block-local variables.
The best way to see what these are is to play around with them at a
-REPL. The only tricky bit is that @var{extp} is a boolean, declaring
-whether the binding is heap-allocated or not. @xref{VM Concepts}, for
-more information.
+REPL. @xref{VM Concepts}, for more information.
Note that bindings information is stored in a program as part of its
metadata thunk, so including it in the generated object code does not
location of a call that is in progress.
@end deffn
+@deffn {Scheme Procedure} program-arities program
+@deffnx {C Function} scm_program_arities (program)
+@deffnx {Scheme Procedure} program-arity program ip
+@deffnx {Scheme Procedure} arity:start arity
+@deffnx {Scheme Procedure} arity:end arity
+@deffnx {Scheme Procedure} arity:nreq arity
+@deffnx {Scheme Procedure} arity:nopt arity
+@deffnx {Scheme Procedure} arity:rest? arity
+@deffnx {Scheme Procedure} arity:kw arity
+@deffnx {Scheme Procedure} arity:allow-other-keys? arity
+Accessors for a representation of the ``arity'' of a program.
+
+The normal case is that a procedure has one arity. For example,
+@code{(lambda (x) x)}, takes one required argument, and that's it. One
+could access that number of required arguments via @code{(arity:nreq
+(program-arities (lambda (x) x)))}. Similarly, @code{arity:nopt} gets
+the number of optional arguments, and @code{arity:rest?} returns a true
+value if the procedure has a rest arg.
+
+@code{arity:kw} returns a list of @code{(@var{kw} . @var{idx})} pairs,
+if the procedure has keyword arguments. The @var{idx} refers to the
+@var{idx}th local variable; @xref{Variables and the VM}, for more
+information. Finally @code{arity:allow-other-keys?} returns a true
+value if other keys are allowed. @xref{Optional Arguments}, for more
+information.
+
+So what about @code{arity:start} and @code{arity:end}, then? They
+return the range of bytes in the program's bytecode for which a given
+arity is valid. You see, a procedure can actually have more than one
+arity. The question, ``what is a procedure's arity'' only really makes
+sense at certain points in the program, delimited by these
+@code{arity:start} and @code{arity:end} values.
+@end deffn
+
@deffn {Scheme Procedure} program-properties program
Return the properties of a @code{program} as an association list,
keyed by property name (a symbol).
@node Optional Arguments
@subsection Optional Arguments
-@c FIXME::martin: Review me!
-
Scheme procedures, as defined in R5RS, can either handle a fixed number
of actual arguments, or a fixed number of actual arguments followed by
arbitrarily many additional arguments. Writing procedures of variable
arity can be useful, but unfortunately, the syntactic means for handling
argument lists of varying length is a bit inconvenient. It is possible
-to give names to the fixed number of argument, but the remaining
+to give names to the fixed number of arguments, but the remaining
(optional) arguments can be only referenced as a list of values
(@pxref{Lambda}).
-Guile comes with the module @code{(ice-9 optargs)}, which makes using
-optional arguments much more convenient. In addition, this module
-provides syntax for handling keywords in argument lists
-(@pxref{Keywords}).
-
-Before using any of the procedures or macros defined in this section,
-you have to load the module @code{(ice-9 optargs)} with the statement:
-
-@cindex @code{optargs}
-@lisp
-(use-modules (ice-9 optargs))
-@end lisp
+For this reason, Guile provides an extension to @code{lambda},
+@code{lambda*}, which allows the user to define procedures with
+optional and keyword arguments. In addition, Guile's virtual machine
+has low-level support for optional and keyword argument dispatch.
+Calls to procedures with optional and keyword arguments can be made
+cheaply, without allocating a rest list.
@menu
-* let-optional Reference:: Locally binding optional arguments.
-* let-keywords Reference:: Locally binding keywords arguments.
-* lambda* Reference:: Creating advanced argument handling procedures.
-* define* Reference:: Defining procedures and macros.
+* lambda* and define*:: Creating advanced argument handling procedures.
+* ice-9 optargs:: (ice-9 optargs) provides some utilities.
@end menu
-@node let-optional Reference
-@subsubsection let-optional Reference
-
-@c FIXME::martin: Review me!
-
-The syntax @code{let-optional} and @code{let-optional*} are for
-destructuring rest argument lists and giving names to the various list
-elements. @code{let-optional} binds all variables simultaneously, while
-@code{let-optional*} binds them sequentially, consistent with @code{let}
-and @code{let*} (@pxref{Local Bindings}).
-
-@deffn {library syntax} let-optional rest-arg (binding @dots{}) expr @dots{}
-@deffnx {library syntax} let-optional* rest-arg (binding @dots{}) expr @dots{}
-These two macros give you an optional argument interface that is very
-@dfn{Schemey} and introduces no fancy syntax. They are compatible with
-the scsh macros of the same name, but are slightly extended. Each of
-@var{binding} may be of one of the forms @var{var} or @code{(@var{var}
-@var{default-value})}. @var{rest-arg} should be the rest-argument of the
-procedures these are used from. The items in @var{rest-arg} are
-sequentially bound to the variable names are given. When @var{rest-arg}
-runs out, the remaining vars are bound either to the default values or
-@code{#f} if no default value was specified. @var{rest-arg} remains
-bound to whatever may have been left of @var{rest-arg}.
-
-After binding the variables, the expressions @var{expr} @dots{} are
-evaluated in order.
-@end deffn
-
+@node lambda* and define*
+@subsubsection lambda* and define*.
-@node let-keywords Reference
-@subsubsection let-keywords Reference
-
-@code{let-keywords} and @code{let-keywords*} extract values from
-keyword style argument lists, binding local variables to those values
-or to defaults.
-
-@deffn {library syntax} let-keywords args allow-other-keys? (binding @dots{}) body @dots{}
-@deffnx {library syntax} let-keywords* args allow-other-keys? (binding @dots{}) body @dots{}
-@var{args} is evaluated and should give a list of the form
-@code{(#:keyword1 value1 #:keyword2 value2 @dots{})}. The
-@var{binding}s are variables and default expressions, with the
-variables to be set (by name) from the keyword values. The @var{body}
-forms are then evaluated and the last is the result. An example will
-make the syntax clearest,
-
-@example
-(define args '(#:xyzzy "hello" #:foo "world"))
-
-(let-keywords args #t
- ((foo "default for foo")
- (bar (string-append "default" "for" "bar")))
- (display foo)
- (display ", ")
- (display bar))
-@print{} world, defaultforbar
-@end example
-
-The binding for @code{foo} comes from the @code{#:foo} keyword in
-@code{args}. But the binding for @code{bar} is the default in the
-@code{let-keywords}, since there's no @code{#:bar} in the args.
-
-@var{allow-other-keys?} is evaluated and controls whether unknown
-keywords are allowed in the @var{args} list. When true other keys are
-ignored (such as @code{#:xyzzy} in the example), when @code{#f} an
-error is thrown for anything unknown.
-
-@code{let-keywords} is like @code{let} (@pxref{Local Bindings}) in
-that all bindings are made at once, the defaults expressions are
-evaluated (if needed) outside the scope of the @code{let-keywords}.
-
-@code{let-keywords*} is like @code{let*}, each binding is made
-successively, and the default expressions see the bindings previously
-made. This is the style used by @code{lambda*} keywords
-(@pxref{lambda* Reference}). For example,
-
-@example
-(define args '(#:foo 3))
-
-(let-keywords* args #f
- ((foo 99)
- (bar (+ foo 6)))
- (display bar))
-@print{} 9
-@end example
-
-The expression for each default is only evaluated if it's needed,
-ie. if the keyword doesn't appear in @var{args}. So one way to make a
-keyword mandatory is to throw an error of some sort as the default.
-
-@example
-(define args '(#:start 7 #:finish 13))
-
-(let-keywords* args #t
- ((start 0)
- (stop (error "missing #:stop argument")))
- ...)
-@result{} ERROR: missing #:stop argument
-@end example
-@end deffn
-
-
-@node lambda* Reference
-@subsubsection lambda* Reference
-
-When using optional and keyword argument lists, @code{lambda} for
-creating a procedure then @code{let-optional} or @code{let-keywords}
-is a bit lengthy. @code{lambda*} combines the features of those
-macros into a single convenient syntax.
+@code{lambda*} is like @code{lambda}, except with some extensions to
+allow optional and keyword arguments.
@deffn {library syntax} lambda* ([var@dots{}] @* [#:optional vardef@dots{}] @* [#:key vardef@dots{} [#:allow-other-keys]] @* [#:rest var | . var]) @* body
@sp 1
optional arguments are omitted in a call, the variables for them are
bound to @code{#f}.
-@code{lambda*} can also take keyword arguments. For example, a procedure
-defined like this:
+@fnindex define*
+Likewise, @code{define*} is syntactic sugar for defining procedures
+using @code{lambda*}.
+
+@code{lambda*} can also make procedures with keyword arguments. For
+example, a procedure defined like this:
@lisp
-(lambda* (#:key xyzzy larch) '())
+(define* (sir-yes-sir #:key action how-high)
+ (list action how-high))
@end lisp
-can be called with any of the argument lists @code{(#:xyzzy 11)},
-@code{(#:larch 13)}, @code{(#:larch 42 #:xyzzy 19)}, @code{()}.
-Whichever arguments are given as keywords are bound to values (and
-those not given are @code{#f}).
+can be called as @code{(sir-yes-sir #:action 'jump)},
+@code{(sir-yes-sir #:how-high 13)}, @code{(sir-yes-sir #:action
+'lay-down #:how-high 0)}, or just @code{(sir-yes-sir)}. Whichever
+arguments are given as keywords are bound to values (and those not
+given are @code{#f}).
Optional and keyword arguments can also have default values to take
when not present in a call, by giving a two-element list of variable
name and expression. For example in
@lisp
-(lambda* (foo #:optional (bar 42) #:key (baz 73))
- (list foo bar baz))
+(define* (frob foo #:optional (bar 42) #:key (baz 73))
+ (list foo bar baz))
@end lisp
@var{foo} is a fixed argument, @var{bar} is an optional argument with
example,
@lisp
-((lambda* (#:key (heads 0) (tails 0))
- (display (list heads tails)))
- #:heads 37 #:tails 42 #:heads 99)
+(define* (flips #:key (heads 0) (tails 0))
+ (display (list heads tails)))
+
+(flips #:heads 37 #:tails 42 #:heads 99)
@print{} (99 42)
@end lisp
@end lisp
@code{#:optional} and @code{#:key} establish their bindings
-successively, from left to right, as per @code{let-optional*} and
-@code{let-keywords*}. This means default expressions can refer back
-to prior parameters, for example
+successively, from left to right. This means default expressions can
+refer back to prior parameters, for example
@lisp
(lambda* (start #:optional (end (+ 10 start)))
((> i end))
(display i)))
@end lisp
+
+The exception to this left-to-right scoping rule is the rest argument.
+If there is a rest argument, it is bound after the optional arguments,
+but before the keyword arguments.
@end deffn
-@node define* Reference
-@subsubsection define* Reference
+@node ice-9 optargs
+@subsubsection (ice-9 optargs)
-@c FIXME::martin: Review me!
+Before Guile 2.0, @code{lambda*} and @code{define*} were implemented
+using macros that processed rest list arguments. This was not optimal,
+as calling procedures with optional arguments had to allocate rest
+lists at every procedure invocation. Guile 2.0 improved this
+situation by bringing optional and keyword arguments into Guile's
+core.
-Just like @code{define} has a shorthand notation for defining procedures
-(@pxref{Lambda Alternatives}), @code{define*} is provided as an
-abbreviation of the combination of @code{define} and @code{lambda*}.
+However there are occasions in which you have a list and want to parse
+it for optional or keyword arguments. Guile's @code{(ice-9 optargs)}
+provides some macros to help with that task.
-@code{define*-public} is the @code{lambda*} version of
-@code{define-public}; @code{defmacro*} and @code{defmacro*-public} exist
-for defining macros with the improved argument list handling
-possibilities. The @code{-public} versions not only define the
-procedures/macros, but also export them from the current module.
+The syntax @code{let-optional} and @code{let-optional*} are for
+destructuring rest argument lists and giving names to the various list
+elements. @code{let-optional} binds all variables simultaneously, while
+@code{let-optional*} binds them sequentially, consistent with @code{let}
+and @code{let*} (@pxref{Local Bindings}).
-@deffn {library syntax} define* formals body
-@deffnx {library syntax} define*-public formals body
-@code{define*} and @code{define*-public} support optional arguments with
-a similar syntax to @code{lambda*}. They also support arbitrary-depth
-currying, just like Guile's define. Some examples:
+@deffn {library syntax} let-optional rest-arg (binding @dots{}) expr @dots{}
+@deffnx {library syntax} let-optional* rest-arg (binding @dots{}) expr @dots{}
+These two macros give you an optional argument interface that is very
+@dfn{Schemey} and introduces no fancy syntax. They are compatible with
+the scsh macros of the same name, but are slightly extended. Each of
+@var{binding} may be of one of the forms @var{var} or @code{(@var{var}
+@var{default-value})}. @var{rest-arg} should be the rest-argument of the
+procedures these are used from. The items in @var{rest-arg} are
+sequentially bound to the variable names are given. When @var{rest-arg}
+runs out, the remaining vars are bound either to the default values or
+@code{#f} if no default value was specified. @var{rest-arg} remains
+bound to whatever may have been left of @var{rest-arg}.
-@lisp
-(define* (x y #:optional a (z 3) #:key w . u)
- (display (list y z u)))
-@end lisp
-defines a procedure @code{x} with a fixed argument @var{y}, an optional
-argument @var{a}, another optional argument @var{z} with default value 3,
-a keyword argument @var{w}, and a rest argument @var{u}.
+After binding the variables, the expressions @var{expr} @dots{} are
+evaluated in order.
+@end deffn
-@lisp
-(define-public* ((foo #:optional bar) #:optional baz) '())
-@end lisp
+Similarly, @code{let-keywords} and @code{let-keywords*} extract values
+from keyword style argument lists, binding local variables to those
+values or to defaults.
-This illustrates currying. A procedure @code{foo} is defined, which,
-when called with an optional argument @var{bar}, returns a procedure
-that takes an optional argument @var{baz}.
+@deffn {library syntax} let-keywords args allow-other-keys? (binding @dots{}) body @dots{}
+@deffnx {library syntax} let-keywords* args allow-other-keys? (binding @dots{}) body @dots{}
+@var{args} is evaluated and should give a list of the form
+@code{(#:keyword1 value1 #:keyword2 value2 @dots{})}. The
+@var{binding}s are variables and default expressions, with the
+variables to be set (by name) from the keyword values. The @var{body}
+forms are then evaluated and the last is the result. An example will
+make the syntax clearest,
-Of course, @code{define*[-public]} also supports @code{#:rest} and
-@code{#:allow-other-keys} in the same way as @code{lambda*}.
+@example
+(define args '(#:xyzzy "hello" #:foo "world"))
+
+(let-keywords args #t
+ ((foo "default for foo")
+ (bar (string-append "default" "for" "bar")))
+ (display foo)
+ (display ", ")
+ (display bar))
+@print{} world, defaultforbar
+@end example
+
+The binding for @code{foo} comes from the @code{#:foo} keyword in
+@code{args}. But the binding for @code{bar} is the default in the
+@code{let-keywords}, since there's no @code{#:bar} in the args.
+
+@var{allow-other-keys?} is evaluated and controls whether unknown
+keywords are allowed in the @var{args} list. When true other keys are
+ignored (such as @code{#:xyzzy} in the example), when @code{#f} an
+error is thrown for anything unknown.
+@end deffn
+
+@code{(ice-9 optargs)} also provides some more @code{define*} sugar,
+which is not so useful with modern Guile coding, but still supported:
+@code{define*-public} is the @code{lambda*} version of
+@code{define-public}; @code{defmacro*} and @code{defmacro*-public}
+exist for defining macros with the improved argument list handling
+possibilities. The @code{-public} versions not only define the
+procedures/macros, but also export them from the current module.
+
+@deffn {library syntax} define*-public formals body
+Like a mix of @code{define*} and @code{define-public}.
@end deffn
@deffn {library syntax} defmacro* name formals body
@lisp
(defmacro* transmorgify (a #:optional b)
- (a 1))
+ (a 1))
@end lisp
@end deffn
+@node Case-lambda
+@subsection Case-lambda
+@cindex SRFI-16
+@cindex variable arity
+@cindex arity, variable
+
+R5RS's rest arguments are indeed useful and very general, but they
+often aren't the most appropriate or efficient means to get the job
+done. For example, @code{lambda*} is a much better solution to the
+optional argument problem than @code{lambda} with rest arguments.
+
+@fnindex case-lambda
+Likewise, @code{case-lambda} works well for when you want one
+procedure to do double duty (or triple, or ...), without the penalty
+of consing a rest list.
+
+For example:
+
+@lisp
+(define (make-accum n)
+ (case-lambda
+ (() n)
+ ((m) (set! n (+ n m)) n)))
+
+(define a (make-accum 20))
+(a) @result{} 20
+(a 10) @result{} 30
+(a) @result{} 30
+@end lisp
+
+The value returned by a @code{case-lambda} form is a procedure which
+matches the number of actual arguments against the formals in the
+various clauses, in order. The first matching clause is selected, the
+corresponding values from the actual parameter list are bound to the
+variable names in the clauses and the body of the clause is evaluated.
+If no clause matches, an error is signalled.
+
+The syntax of the @code{case-lambda} form is defined in the following
+EBNF grammar. @dfn{Formals} means a formal argument list just like
+with @code{lambda} (@pxref{Lambda}).
+
+@example
+@group
+<case-lambda>
+ --> (case-lambda <case-lambda-clause>)
+<case-lambda-clause>
+ --> (<formals> <definition-or-command>*)
+<formals>
+ --> (<identifier>*)
+ | (<identifier>* . <identifier>)
+ | <identifier>
+@end group
+@end example
+
+Rest lists can be useful with @code{case-lambda}:
+
+@lisp
+(define plus
+ (case-lambda
+ (() 0)
+ ((a) a)
+ ((a b) (+ a b))
+ ((a b . rest) (apply plus (+ a b) rest))))
+(plus 1 2 3) @result{} 6
+@end lisp
+
+@fnindex case-lambda*
+Also, for completeness. Guile defines @code{case-lambda*} as well,
+which is like @code{case-lambda}, except with @code{lambda*} clauses.
+A @code{case-lambda*} clause matches if the arguments fill the
+required arguments, but are not too many for the optional and/or rest
+arguments.
+
+Keyword arguments are possible with @code{case-lambda*}, but they do
+not contribute to the ``matching'' behavior. That is to say,
+@code{case-lambda*} matches only on required, optional, and rest
+arguments, and on the predicate; keyword arguments may be present but
+do not contribute to the ``success'' of a match. In fact a bad keyword
+argument list may cause an error to be raised.
@node Procedure Properties
@subsection Procedure Properties and Meta-information
-@c FIXME::martin: Review me!
+In addition to the information that is strictly necessary to run,
+procedures may have other associated information. For example, the
+name of a procedure is information not for the procedure, but about
+the procedure. This meta-information can be accessed via the procedure
+properties interface.
-Procedures always have attached the environment in which they were
-created and information about how to apply them to actual arguments. In
-addition to that, properties and meta-information can be stored with
-procedures. The procedures in this section can be used to test whether
-a given procedure satisfies a condition; and to access and set a
-procedure's property.
-
-The first group of procedures are predicates to test whether a Scheme
-object is a procedure, or a special procedure, respectively.
-@code{procedure?} is the most general predicates, it returns @code{#t}
-for any kind of procedure. @code{closure?} does not return @code{#t}
-for primitive procedures, and @code{thunk?} only returns @code{#t} for
-procedures which do not accept any arguments.
+The first group of procedures in this meta-interface are predicates to
+test whether a Scheme object is a procedure, or a special procedure,
+respectively. @code{procedure?} is the most general predicates, it
+returns @code{#t} for any kind of procedure. @code{closure?} does not
+return @code{#t} for primitive procedures, and @code{thunk?} only
+returns @code{#t} for procedures which do not accept any arguments.
@rnindex procedure?
@deffn {Scheme Procedure} procedure? obj
@deffn {Scheme Procedure} closure? obj
@deffnx {C Function} scm_closure_p (obj)
-Return @code{#t} if @var{obj} is a closure.
+Return @code{#t} if @var{obj} is a closure. This category somewhat
+misnamed, actually, as it applies only to interpreted procedures, not
+compiled procedures. But since it has historically been used more to
+select on implementation details than on essence (closure or not), we
+keep it here for compatibility. Don't use it in new code, though.
@end deffn
@deffn {Scheme Procedure} thunk? obj
Return @code{#t} if @var{obj} is a thunk.
@end deffn
-@c FIXME::martin: Is that true?
@cindex procedure properties
-Procedure properties are general properties to be attached to
-procedures. These can be the name of a procedure or other relevant
+Procedure properties are general properties associated with
+procedures. These can be the name of a procedure or other relevant
information, such as debug hints.
@deffn {Scheme Procedure} procedure-name proc
@deffn {Scheme Procedure} procedure-source proc
@deffnx {C Function} scm_procedure_source (proc)
-Return the source of the procedure @var{proc}.
+Return the source of the procedure @var{proc}. Returns @code{#f} if
+the source code is not available.
@end deffn
@deffn {Scheme Procedure} procedure-environment proc
@deffnx {C Function} scm_procedure_environment (proc)
-Return the environment of the procedure @var{proc}.
+Return the environment of the procedure @var{proc}. Very deprecated.
@end deffn
@deffn {Scheme Procedure} procedure-properties proc
@deffnx {C Function} scm_procedure_properties (proc)
-Return @var{obj}'s property list.
+Return the properties associated with @var{proc}, as an association
+list.
@end deffn
-@deffn {Scheme Procedure} procedure-property obj key
-@deffnx {C Function} scm_procedure_property (obj, key)
-Return the property of @var{obj} with name @var{key}.
+@deffn {Scheme Procedure} procedure-property proc key
+@deffnx {C Function} scm_procedure_property (proc, key)
+Return the property of @var{proc} with name @var{key}.
@end deffn
@deffn {Scheme Procedure} set-procedure-properties! proc alist
@deffnx {C Function} scm_set_procedure_properties_x (proc, alist)
-Set @var{obj}'s property list to @var{alist}.
+Set @var{proc}'s property list to @var{alist}.
@end deffn
-@deffn {Scheme Procedure} set-procedure-property! obj key value
-@deffnx {C Function} scm_set_procedure_property_x (obj, key, value)
-In @var{obj}'s property list, set the property named @var{key} to
+@deffn {Scheme Procedure} set-procedure-property! proc key value
+@deffnx {C Function} scm_set_procedure_property_x (proc, key, value)
+In @var{proc}'s property list, set the property named @var{key} to
@var{value}.
@end deffn
@node Internal Macros
@subsection Internal Representation of Macros and Syntax
+[FIXME: used to be true. Isn't any more. Use syntax-rules or
+syntax-case please :)]
+
Internally, Guile uses three different flavors of macros. The three
flavors are called @dfn{acro} (or @dfn{syntax}), @dfn{macro} and
@dfn{mmacro}.
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Blocking
@subsection Blocking in Guile Mode
-A thread must not block outside of a libguile function while it is in
-guile mode. The following functions can be used to temporily leave
-guile mode or to perform some common blocking operations in a supported
-way.
+Up to Guile version 1.8, a thread blocked in guile mode would prevent
+the garbage collector from running. Thus threads had to explicitly
+leave guile mode with @code{scm_without_guile ()} before making a
+potentially blocking call such as a mutex lock, a @code{select ()}
+system call, etc. The following functions could be used to temporarily
+leave guile mode or to perform some common blocking operations in a
+supported way.
+
+Starting from Guile 2.0, blocked threads no longer hinder garbage
+collection. Thus, the functions below are not needed anymore. They can
+still be used to inform the GC that a thread is about to block, giving
+it a (small) optimization opportunity for ``stop the world'' garbage
+collections, should they occur while the thread is blocked.
@deftypefn {C Function} {void *} scm_without_guile (void *(*func) (void *), void *data)
Leave guile mode, call @var{func} on @var{data}, enter guile mode and
@var{data}.
@end deftypefn
-@c @node Futures
-@c @subsection Futures
-@c @cindex futures
-
-@c -- Futures are disabled for the time being, see futures.h for an
-@c -- explanation.
-
-@c Futures are a convenient way to run a calculation in a new thread, and
-@c only wait for the result when it's actually needed.
-
-@c Futures are similar to promises (@pxref{Delayed Evaluation}), in that
-@c they allow mainline code to continue immediately. But @code{delay}
-@c doesn't evaluate at all until forced, whereas @code{future} starts
-@c immediately in a new thread.
-
-@c @deffn {syntax} future expr
-@c Begin evaluating @var{expr} in a new thread, and return a ``future''
-@c object representing the calculation.
-@c @end deffn
-
-@c @deffn {Scheme Procedure} make-future thunk
-@c @deffnx {C Function} scm_make_future (thunk)
-@c Begin evaluating the call @code{(@var{thunk})} in a new thread, and
-@c return a ``future'' object representing the calculation.
-@c @end deffn
-
-@c @deffn {Scheme Procedure} future-ref f
-@c @deffnx {C Function} scm_future_ref (f)
-@c Return the value computed by the future @var{f}. If @var{f} has not
-@c yet finished executing then wait for it to do so.
-@c @end deffn
-
-
@node Parallel Forms
@subsection Parallel forms
@cindex parallel forms
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Smobs
@section Smobs
+@cindex smob
+
This chapter contains reference information related to defining and
working with smobs. See @ref{Defining New Types (Smobs)} for a
tutorial-like introduction to smobs.
@code{scm_set_smob_print}, and/or @code{scm_set_smob_equalp}.
@end deftypefun
+@cindex finalizer
+@cindex finalization
+
+@deftypefn {C Function} void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM obj))
+This function sets the smob freeing procedure (sometimes referred to as
+a @dfn{finalizer}) for the smob type specified by the tag
+@var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}.
+
+The @var{free} procedure must deallocate all resources that are
+directly associated with the smob instance @var{OBJ}. It must assume
+that all @code{SCM} values that it references have already been freed
+and are thus invalid.
+
+It must also not call any libguile function or macro except
+@code{scm_gc_free}, @code{SCM_SMOB_FLAGS}, @code{SCM_SMOB_DATA},
+@code{SCM_SMOB_DATA_2}, and @code{SCM_SMOB_DATA_3}.
+
+The @var{free} procedure must return 0.
+
+Note that defining a freeing procedure is not necessary if the resources
+associated with @var{obj} consists only of memory allocated with
+@code{scm_gc_malloc} or @code{scm_gc_malloc_pointerless} because this
+memory is automatically reclaimed by the garbage collector when it is no
+longer needed (@pxref{Memory Blocks, @code{scm_gc_malloc}}).
+@end deftypefn
+
+@cindex precise marking
+
@deftypefn {C Function} void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM obj))
This function sets the smob marking procedure for the smob type specified by
the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}.
+Defining a marking procedure may sometimes be unnecessary because large
+parts of the process' memory (with the exception of
+@code{scm_gc_malloc_pointerless} regions, and @code{malloc}- or
+@code{scm_malloc}-allocated memory) are scanned for live
+pointers@footnote{Conversely, in Guile up to the 1.8 series, the marking
+procedure was always required. The reason is that Guile's GC would only
+look for pointers in the memory area used for built-in types (the
+@dfn{cell heap}), not in user-allocated or statically allocated memory.
+This approach is often referred to as @dfn{precise marking}.}.
+
The @var{mark} procedure must cause @code{scm_gc_mark} to be called
for every @code{SCM} value that is directly referenced by the smob
instance @var{obj}. One of these @code{SCM} values can be returned
@code{SCM_SMOB_DATA_2}, and @code{SCM_SMOB_DATA_3}.
@end deftypefn
-@deftypefn {C Function} void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM obj))
-This function sets the smob freeing procedure for the smob type
-specified by the tag @var{tc}. @var{tc} is the tag returned by
-@code{scm_make_smob_type}.
-
-The @var{free} procedure must deallocate all resources that are
-directly associated with the smob instance @var{OBJ}. It must assume
-that all @code{SCM} values that it references have already been freed
-and are thus invalid.
-
-It must also not call any libguile function or macro except
-@code{scm_gc_free}, @code{SCM_SMOB_FLAGS}, @code{SCM_SMOB_DATA},
-@code{SCM_SMOB_DATA_2}, and @code{SCM_SMOB_DATA_3}.
-
-The @var{free} procedure must return 0.
-@end deftypefn
@deftypefn {C Function} void scm_set_smob_print (scm_t_bits tc, int (*print) (SCM obj, SCM port, scm_print_state* pstate))
This function sets the smob printing procedure for the smob type
when compiling the subsequent expression.
For Scheme, an environment may be one of two things:
+
@itemize
@item @code{#f}, in which case compilation is performed in the context
of the current module; or
@item a module, which specifies the context of the compilation.
@end itemize
+By default, the @code{compile} and @code{compile-file} procedures
+compile in a fresh module, such that bindings and macros introduced by
+the expression being compiled are isolated:
+
+@example
+(eq? (current-module) (compile '(current-module)))
+@result{} #f
+
+(compile '(define hello 'world))
+(defined? 'hello)
+@result{} #f
+
+(define / *)
+(eq? (compile '/) /)
+@result{} #f
+@end example
+
+Similarly, changes to the @code{current-reader} fluid (@pxref{Loading,
+@code{current-reader}}) are isolated:
+
+@example
+(compile '(fluid-set! current-reader (lambda args 'fail)))
+(fluid-ref current-reader)
+@result{} #f
+@end example
+
+Nevertheless, having the compiler and @dfn{compilee} share the same name
+space can be achieved by explicitly passing @code{(current-module)} as
+the compilation environment:
+
+@example
+(define hello 'world)
+(compile 'hello #:env (current-module))
+@result{} world
+@end example
+
@node Tree-IL
@subsection Tree-IL
@goops{} is the object oriented extension to @guile{}. Its
implementation is derived from @w{STk-3.99.3} by Erick Gallesio and
-version 1.3 of Gregor Kiczales @cite{Tiny-Clos}. It is very close in
+version 1.3 of Gregor Kiczales' @cite{Tiny-Clos}. It is very close in
spirit to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is
adapted for the Scheme language. While GOOPS is not compatible with any
of these systems, GOOPS contains a compatibility module which allows for
interpreter. To make that straightforward, Guile provides the
@code{scm_boot_guile} and @code{scm_shell} function.
+For more about these functions, see @ref{Initialization}.
+
@node A Sample Guile Main Program
@subsection A Sample Guile Main Program
@sp 1
@defun ftw startname proc ['hash-size n]
-Walk the filesystem tree descending from @var{startname}, calling
+Walk the file system tree descending from @var{startname}, calling
@var{proc} for each file and directory.
Hard links and symbolic links are followed. A file or directory is
@defun nftw startname proc ['chdir] ['depth] ['hash-size n] ['mount] ['physical]
-Walk the filesystem tree starting at @var{startname}, calling
+Walk the file system tree starting at @var{startname}, calling
@var{proc} for each file and directory. @code{nftw} has extra
features over the basic @code{ftw} described above.
@item @code{mount}
Don't cross a mount point, meaning only visit items on the same
-filesystem as @var{startname} (ie.@: the same @code{stat:dev}).
+file system as @var{startname} (ie.@: the same @code{stat:dev}).
@item @code{physical}
Don't follow symbolic links, instead report them to @var{proc} as
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@deffn {Scheme Procedure} inet-aton address
@deffnx {C Function} scm_inet_aton (address)
+This function is deprecated in favor of @code{inet-pton}.
+
Convert an IPv4 Internet address from printable string
(dotted decimal notation) to an integer. E.g.,
@deffn {Scheme Procedure} inet-ntoa inetid
@deffnx {C Function} scm_inet_ntoa (inetid)
+This function is deprecated in favor of @code{inet-ntop}.
+
Convert an IPv4 Internet address to a printable
(dotted decimal notation) string. E.g.,
@lisp
(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1"
-(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}
-ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff
+(inet-ntop AF_INET6 (- (expt 2 128) 1))
+ @result{} "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff"
@end lisp
@end deffn
(@pxref{Network Socket Address}). The return value is unspecified.
@example
-(connect sock AF_INET INADDR_LOCALHOST 23)
-(connect sock (make-socket-address AF_INET INADDR_LOCALHOST 23))
+(connect sock AF_INET INADDR_LOOPBACK 23)
+(connect sock (make-socket-address AF_INET INADDR_LOOPBACK 23))
@end example
@end deffn
@example
(let ((s (socket PF_INET SOCK_STREAM 0)))
- (connect s AF_INET (inet-aton "127.0.0.1") 80)
+ (connect s AF_INET (inet-pton AF_INET "127.0.0.1") 80)
(display "GET / HTTP/1.0\r\n\r\n" s)
(do ((line (read-line s) (read-line s)))
(let ((s (socket PF_INET SOCK_STREAM 0)))
(setsockopt s SOL_SOCKET SO_REUSEADDR 1)
;; @r{Specific address?}
- ;; @r{(bind s AF_INET (inet-aton "127.0.0.1") 2904)}
+ ;; @r{(bind s AF_INET (inet-pton AF_INET "127.0.0.1") 2904)}
(bind s AF_INET INADDR_ANY 2904)
(listen s 5)
operating system never reads this far, but Guile treats this as the end
of the comment begun on the first line by the @samp{#!} characters.
+@item
+If this source code file is not ASCII or ISO-8859-1 encoded, a coding
+declaration such as @code{coding: utf-8} should appear in a comment
+somewhere in the first five lines of the file: see @ref{Character
+Encoding of Source Files}.
+
@item
The rest of the file should be a Scheme program.
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
* SRFI-18:: Multithreading support
* SRFI-19:: Time/Date library.
* SRFI-26:: Specializing parameters
+* SRFI-30:: Nested multi-line block comments
* SRFI-31:: A special form `rec' for recursive evaluation
* SRFI-34:: Exception handling.
* SRFI-35:: Conditions.
@example
guile
+guile-2 ;; starting from Guile 2.x
r5rs
srfi-0
srfi-4
(use-modules (srfi srfi-8))))
@end example
+@cindex @code{guile-2} SRFI-0 feature
+@cindex portability between 2.0 and older versions
+Likewise, testing the @code{guile-2} feature allows code to be portable
+between Guile 2.0 and previous versions of Guile. For instance, it
+makes it possible to write code that accounts for Guile 2.0's compiler,
+yet be correctly interpreted on 1.8 and earlier versions:
+
+@example
+(cond-expand (guile-2 (eval-when (compile)
+ ;; This must be evaluated at compile time.
+ (fluid-set! current-reader my-reader)))
+ (guile
+ ;; Earlier versions of Guile do not have a
+ ;; separate compilation phase.
+ (fluid-set! current-reader my-reader)))
+@end example
+
It should be noted that @code{cond-expand} is separate from the
@code{*features*} mechanism (@pxref{Feature Tracking}), feature
symbols in one are unrelated to those in the other.
@cindex variable arity
@cindex arity, variable
-@c FIXME::martin: Review me!
-
-@findex case-lambda
-The syntactic form @code{case-lambda} creates procedures, just like
-@code{lambda}, but has syntactic extensions for writing procedures of
-varying arity easier.
-
-The syntax of the @code{case-lambda} form is defined in the following
-EBNF grammar.
-
-@example
-@group
-<case-lambda>
- --> (case-lambda <case-lambda-clause>)
-<case-lambda-clause>
- --> (<formals> <definition-or-command>*)
-<formals>
- --> (<identifier>*)
- | (<identifier>* . <identifier>)
- | <identifier>
-@end group
-@end example
-
-The value returned by a @code{case-lambda} form is a procedure which
-matches the number of actual arguments against the formals in the
-various clauses, in order. @dfn{Formals} means a formal argument list
-just like with @code{lambda} (@pxref{Lambda}). The first matching clause
-is selected, the corresponding values from the actual parameter list are
-bound to the variable names in the clauses and the body of the clause is
-evaluated. If no clause matches, an error is signalled.
-
-The following (silly) definition creates a procedure @var{foo} which
-acts differently, depending on the number of actual arguments. If one
-argument is given, the constant @code{#t} is returned, two arguments are
-added and if more arguments are passed, their product is calculated.
-
-@lisp
-(define foo (case-lambda
- ((x) #t)
- ((x y) (+ x y))
- (z
- (apply * z))))
-(foo 'bar)
-@result{}
-#t
-(foo 2 4)
-@result{}
-6
-(foo 3 3 3)
-@result{}
-27
-(foo)
-@result{}
-1
-@end lisp
-
-The last expression evaluates to 1 because the last clause is matched,
-@var{z} is bound to the empty list and the following multiplication,
-applied to zero arguments, yields 1.
-
+SRFI-16 defines a variable-arity @code{lambda} form,
+@code{case-lambda}. This form is available in the default Guile
+environment. @xref{Case-lambda}, for more information.
@node SRFI-17
@subsection SRFI-17 - Generalized set!
@end example
@end deffn
+@node SRFI-30
+@subsection SRFI-30 - Nested Multi-line Comments
+@cindex SRFI-30
+
+Starting from version 2.0, Guile's @code{read} supports SRFI-30/R6RS
+nested multi-line comments by default, @ref{Block Comments}.
+
@node SRFI-31
@subsection SRFI-31 - A special form `rec' for recursive evaluation
@cindex SRFI-31
* Ports and descriptors:: Ports, file descriptors and how they
interact.
* Extended I/O:: Reading and writing to ports.
-* File system:: Working in a hierarchical filesystem.
+* File system:: Working in a hierarchical file system.
* User database:: Information about users from system databases.
* Processes:: Information and control of Unix processes.
* Terminals:: Terminals and pseudo-terminals.
--- /dev/null
+
+* Installation
+
+** How do I install guile-debugging?
+
+After unpacking the .tar.gz file, run the usual sequence of commands:
+
+$ ./configure
+$ make
+$ sudo make install
+
+Then you need to make sure that the directory where guile-debugging's
+Scheme files were installed is included in your Guile's load path.
+(The sequence above will usually install guile-debugging under
+/usr/local, and /usr/local is not in Guile's load path by default,
+unless Guile itself was installed under /usr/local.) You can discover
+your Guile's default load path by typing
+
+$ guile -q -c '(begin (write %load-path) (newline))'
+
+There are two ways to add guile-debugging's installation directory to
+Guile's load path, if it isn't already there.
+
+1. Edit or create the `init.scm' file, which Guile reads on startup,
+ so that it includes a line like this:
+
+ (set! %load-path (cons "/usr/local/share/guile" %load-path))
+
+ but with "/usr/local" replaced by the prefix that you installed
+ guile-debugging under, if not /usr/local.
+
+ The init.scm file must be installed (if it does not already exist
+ there) in one of the directories in Guile's default load-path.
+
+2. Add this line to your .emacs file:
+
+ (setq gds-scheme-directory "/usr/local/share/guile")
+
+ before the `require' or `load' line that loads GDS, but with
+ "/usr/local" replaced by the prefix that you installed
+ guile-debugging under, if not /usr/local.
+
+Finally, if you want guile-debugging's GDS interface to be loaded
+automatically whenever you run Emacs, add this line to your .emacs:
+
+(require 'gds)
+
+* Troubleshooting
+
+** "error in process filter" when starting Emacs (or loading GDS)
+
+This is caused by an internal error in GDS's Scheme code, for which a
+backtrace will have appeared in the gds-debug buffer, so please switch
+to the gds-debug buffer and see what it says there.
+
+The most common cause is a load path problem: Guile cannot find GDS's
+Scheme code because it is not in the known load path. In this case
+you should see the error message "no code for module" somewhere in the
+backtrace. If you see this, please try the remedies described in `How
+do I install guile-debugging?' above, then restart Emacs and see if
+the problem has been cured.
+
+If you don't see "no code for module", or if the described remedies
+don't fix the problem, please send the contents of the gds-debug
+buffer to me at <neil@ossau.uklinux.net>, so I can debug the problem.
+
+If you don't see a backtrace at all in the gds-debug buffer, try the
+next item ...
+
+** "error in process filter" at some other time
+
+This is caused by an internal error somewhere in GDS's Emacs Lisp
+code. If possible, please
+
+- switch on the `debug-on-error' option (M-x set-variable RET
+ debug-on-error RET t RET)
+
+- do whatever you were doing so that the same error happens again
+
+- send the Emacs Lisp stack trace which pops up to me at
+ <neil@ossau.uklinux.net>.
+
+If that doesn't work, please just mail me with as much detail as
+possible of what you were doing when the error occurred.
+
+* GDS Features
+
+** How do I inspect variable values?
+
+Type `e' followed by the name of the variable, then <RET>. This
+works whenever GDS is displaying a stack for an error at at a
+breakpoint. (You can actually `e' to evaluate any expression in the
+local environment of the selected stack frame; inspecting variables is
+the special case of this where the expression is only a variable name.)
+
+If GDS is displaying the associated source code in the window above or
+below the stack, you can see the values of any variables in the
+highlighted code just by hovering your mouse over them.
+
+** How do I change a variable's value?
+
+Type `e' and then `(set! VARNAME NEWVAL)', where VARNAME is the name
+of the variable you want to set and NEWVAL is an expression which
+Guile can evaluate to get the new value. This works whenever GDS is
+displaying a stack for an error at at a breakpoint. The setting will
+take effect in the local environment of the selected stack frame.
+
+** How do I change the expression that Guile is about to evaluate?
+
+Type `t' followed by the expression that you want Guile to evaluate
+instead, then <RET>.
+
+Then type one of the commands that tells Guile to continue execution.
+
+(Tweaking expressions, as described here, is only supported by the
+latest CVS version of Guile. The GDS stack display tells you when
+tweaking is possible by adding "(tweakable)" to the first line of the
+stack window.)
+
+** How do I return a value from the current stack frame different to what the evaluator has calculated?
+
+You have to be at the normal exit of the relevant frame first, so if
+GDS is not already showing you the normally calculated return value,
+type `o' to finish the evaluation of the selected frame.
+
+Then type `t' followed by the value you want to return, and <RET>.
+The value that you type can be any expression, but note that it will
+not be evaluated before being returned; for example if you type `(+ 2
+3)', the return value will be a three-element list, not 5.
+
+Finally type one of the commands that tells Guile to continue
+execution.
+
+(Tweaking return values, as described here, is only supported by the
+latest CVS version of Guile. The GDS stack display tells you when
+tweaking is possible by adding "(tweakable)" to the first line of the
+stack window.)
+
+** How do I step over a line of code?
+
+Scheme isn't organized by lines, so it doesn't really make sense to
+think of stepping over lines. Instead please see the next entry on
+stepping over expressions.
+
+** How do I step over an expression?
+
+It depends what you mean by "step over". If you mean that you want
+Guile to evaluate that expression normally, but then show you its
+return value, type `o', which does exactly that.
+
+If you mean that you want to skip the evaluation of that expression
+(for example because it has side effects that you don't want to
+happen), use `t' to change the expression to something else which
+Guile will evaluate instead.
+
+There has to be a substitute expression so Guile can calculate a value
+to return to the calling frame. If you know at a particular point
+that the return value is not important, you can type `t #f <RET>' or
+`t 0 <RET>'.
+
+See `How do I change the expression that Guile is about to evaluate?'
+above for more on using `t'.
+
+** How do I move up and down the call stack?
+
+Type `u' to move up and `d' to move down. "Up" in GDS means to a more
+"inner" frame, and "down" means to a more "outer" frame.
+
+** How do I run until the next breakpoint?
+
+Type `g' (for "go").
+
+** How do I run until the end of the selected stack frame?
+
+Type `o'.
+
+** How do I set a breakpoint?
+
+First identify the code that you want to set the breakpoint in, and
+what kind of breakpoint you want. To set a breakpoint on entry to a
+top level procedure, move the cursor to anywhere in the procedure
+definition, and make sure that the region/mark is inactive. To set a
+breakpoint on a particular expression (or sequence of expressions) set
+point and mark so that the region covers the opening parentheses of
+all the target expressions.
+
+Then type ...
+
+ `C-c C-b d' for a `debug' breakpoint, which means that GDS will
+ display the stack when the breakpoint is hit
+
+ `C-c C-b t' for a `trace' breakpoint, which means that the start and
+ end of the relevant procedure or expression(s) will be traced to the
+ *GDS Trace* buffer
+
+ `C-c C-b T' for a `trace-subtree' breakpoint, which means that every
+ evaluation step involved in the evaluation of the relevant procedure
+ or expression(s) will be traced to the *GDS Trace* buffer.
+
+You can also type `C-x <SPC>', which does the same as one of the
+above, depending on the value of `gds-default-breakpoint-type'.
+
+** How do I clear a breakpoint?
+
+Select a region containing the breakpoints that you want to clear, and
+type `C-c C-b <DEL>'.
+
+** How do I trace calls to a particular procedure or evaluations of a particular expression?
+
+In GDS this means setting a breakpoint whose type is `trace' or
+`trace-subtree'. See `How do I set a breakpoint?' above.
+
+* Development
+
+** How can I follow or contribute to guile-debugging's development?
+
+guile-debugging is hosted at http://gna.org, so please see the project
+page there. Feel free to raise bugs, tasks containing patches or
+feature requests, and so on. You can also write directly to me by
+email: <neil@ossau.uklinux.net>.
+
+
+Local Variables:
+mode: outline
+End:
"-q"
"--debug"
"-c"
- code))
- (client nil))
+ code)))
;; Note that this process can be killed automatically on Emacs
;; exit.
(process-kill-without-query proc)
;; Set up a process filter to catch the new client's number.
(set-process-filter proc
(lambda (proc string)
- (setq client (string-to-number string))
(if (process-buffer proc)
(with-current-buffer (process-buffer proc)
- (insert string)))))
+ (insert string)
+ (or gds-client
+ (save-excursion
+ (goto-char (point-min))
+ (setq gds-client
+ (condition-case nil
+ (read (current-buffer))
+ (error nil)))))))))
;; Accept output from the new process until we have its number.
- (while (not client)
+ (while (not (with-current-buffer (process-buffer proc) gds-client))
(accept-process-output proc))
;; Return the new process's client number.
- client))
+ (with-current-buffer (process-buffer proc) gds-client)))
;;;; Evaluating code.
(map (make-sparse-keymap)))
(define-key map [mouse-1] 'gds-show-last-stack)
(define-key map "\C-m" 'gds-show-last-stack)
- (insert "[click here to show error stack]")
+ (insert "[click here (or RET) to show error stack]")
(add-text-properties beg (point)
(list 'keymap map
'mouse-face 'highlight))
- (insert "\n")))
+ (insert "\n")
+ (add-text-properties (1- (point)) (point)
+ (list 'keymap map))))
(goto-char (point-min))
(gds-associate-buffer client))
(pop-to-buffer buf)
:group 'gds
:type '(choice (const :tag "nil" nil) directory))
-(defun gds-start-server (procname port-or-path protocol-handler &optional bufname)
- "Start a GDS server process called PROCNAME, listening on TCP port
-or Unix domain socket PORT-OR-PATH. PROTOCOL-HANDLER should be a
-function that accepts and processes one protocol form. Optional arg
-BUFNAME specifies the name of the buffer that is used for process
-output; if not specified the buffer name is the same as the process
-name."
- (with-current-buffer (get-buffer-create (or bufname procname))
+(defun gds-start-server (procname unix-socket-name tcp-port protocol-handler)
+ "Start a GDS server process called PROCNAME, listening on Unix
+domain socket UNIX-SOCKET-NAME and TCP port number TCP-PORT.
+PROTOCOL-HANDLER should be a function that accepts and processes
+one protocol form."
+ (with-current-buffer (get-buffer-create procname)
(erase-buffer)
(let* ((code (format "(begin
%s
(use-modules (ice-9 gds-server))
- (run-server %S))"
+ (run-server %S %S))"
(if gds-scheme-directory
(concat "(set! %load-path (cons "
(format "%S" gds-scheme-directory)
" %load-path))")
"")
- port-or-path))
+ unix-socket-name
+ tcp-port))
(process-connection-type nil) ; use a pipe
(proc (start-process procname
(current-buffer)
--- /dev/null
+
+;; Test utility code.
+(defun gds-test-execute-keys (keys &optional keys2)
+ (execute-kbd-macro (apply 'vector (listify-key-sequence keys))))
+
+(defvar gds-test-expecting nil)
+
+(defun gds-test-protocol-hook (form)
+ (message "[protocol: %s]" (car form))
+ (if (eq (car form) gds-test-expecting)
+ (setq gds-test-expecting nil)))
+
+(defun gds-test-expect-protocol (proc &optional timeout)
+ (message "[expect: %s]" proc)
+ (setq gds-test-expecting proc)
+ (while gds-test-expecting
+ (or (accept-process-output gds-debug-server (or timeout 5))
+ (error "Timed out after %ds waiting for %s" (or timeout 5) proc))))
+
+(defun gds-test-check-buffer (name &rest strings)
+ (let ((buf (or (get-buffer name) (error "No %s buffer" name))))
+ (save-excursion
+ (set-buffer buf)
+ (goto-char (point-min))
+ (while strings
+ (search-forward (car strings))
+ (setq strings (cdr strings))))))
+
+(defun TEST (desc)
+ (message "TEST: %s" desc))
+
+;; Make sure we take GDS elisp code from this code tree.
+(setq load-path (cons (concat default-directory "emacs/") load-path))
+
+;; Protect the tests so we can do some cleanups in case of error.
+(unwind-protect
+ (progn
+
+ ;; Visit the tutorial.
+ (find-file "gds-tutorial.txt")
+
+ (TEST "Load up GDS.")
+ (search-forward "(require 'gds)")
+ (setq load-path (cons (concat default-directory "emacs/") load-path))
+ (gds-test-execute-keys "\C-x\C-e")
+
+ ;; Install our testing hook.
+ (add-hook 'gds-protocol-hook 'gds-test-protocol-hook)
+
+ (TEST "Help.")
+ (search-forward "(list-ref")
+ (backward-char 2)
+ (gds-test-execute-keys "\C-hg\C-m")
+ (gds-test-expect-protocol 'eval-results 10)
+ (gds-test-check-buffer "*Guile Help*"
+ "help list-ref"
+ "is a primitive procedure in the (guile) module")
+
+ (TEST "Completion.")
+ (re-search-forward "^with-output-to-s")
+ (gds-test-execute-keys "\e\C-i")
+ (beginning-of-line)
+ (or (looking-at "with-output-to-string")
+ (error "Expected completion `with-output-to-string' failed"))
+
+ (TEST "Eval defun.")
+ (search-forward "(display z)")
+ (gds-test-execute-keys "\e\C-x")
+ (gds-test-expect-protocol 'eval-results)
+ (gds-test-check-buffer "*Guile Evaluation*"
+ "(let ((x 1) (y 2))"
+ "Arctangent is: 0.46"
+ "=> 0.46")
+
+ (TEST "Multiple values.")
+ (search-forward "(values 'a ")
+ (gds-test-execute-keys "\e\C-x")
+ (gds-test-expect-protocol 'eval-results)
+ (gds-test-check-buffer "*Guile Evaluation*"
+ "(values 'a"
+ "hello world"
+ "=> a"
+ "=> b"
+ "=> c")
+
+ (TEST "Eval region with multiple expressions.")
+ (search-forward "(display \"Arctangent is: \")")
+ (beginning-of-line)
+ (push-mark nil nil t)
+ (forward-line 3)
+ (gds-test-execute-keys "\C-c\C-r")
+ (gds-test-expect-protocol 'eval-results)
+ (gds-test-check-buffer "*Guile Evaluation*"
+ "(display \"Arctangent is"
+ "Arctangent is:"
+ "=> no (or unspecified) value"
+ "ERROR: Unbound variable: z"
+ "=> error-in-evaluation"
+ "Evaluating expression 3"
+ "=> no (or unspecified) value")
+
+ (TEST "Eval syntactically unbalanced region.")
+ (search-forward "(let ((z (atan x y)))")
+ (beginning-of-line)
+ (push-mark nil nil t)
+ (forward-line 4)
+ (gds-test-execute-keys "\C-c\C-r")
+ (gds-test-expect-protocol 'eval-results)
+ (gds-test-check-buffer "*Guile Evaluation*"
+ "(let ((z (atan"
+ "Reading expressions to evaluate"
+ "ERROR"
+ "end of file"
+ "=> error-in-read")
+
+ (TEST "Stepping through an evaluation.")
+ (search-forward "(for-each (lambda (x)")
+ (forward-line 1)
+ (push-mark nil nil t)
+ (forward-line 1)
+ (gds-test-execute-keys "\C-u\e\C-x")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys " ")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "o")
+ (gds-test-expect-protocol 'stack)
+ (gds-test-execute-keys "g")
+ (gds-test-expect-protocol 'eval-results)
+ (gds-test-check-buffer "*Guile Evaluation*"
+ "(for-each (lambda"
+ "Evaluating in current module"
+ "3 cubed is 27"
+ "=> no (or unspecified) value")
+
+ ;; Done.
+ (message "====================================")
+ (message "gds-test.el completed without errors")
+ (message "====================================")
+
+ )
+
+ (switch-to-buffer "gds-debug")
+ (write-region (point-min) (point-max) "gds-test.debug")
+
+ (switch-to-buffer "*GDS Transcript*")
+ (write-region (point-min) (point-max) "gds-test.transcript")
+
+ )
--- /dev/null
+#!/bin/sh
+GUILE_LOAD_PATH=$(pwd) emacs --batch --no-site-file -q -l gds-test.el < gds-test.stdin
--- /dev/null
+
+;; Welcome to the GDS tutorial!
+
+;; This tutorial teaches the use of GDS by leading you through a set
+;; of examples where you actually use GDS, in Emacs, along the way.
+;; To get maximum benefit, therefore, you should be reading this
+;; tutorial in Emacs.
+
+;; ** GDS setup
+
+;; The first thing to do, if you haven't already, is to load the GDS
+;; library into Emacs. The Emacs Lisp expression for this is:
+
+(require 'gds)
+
+;; So, if you don't already have this in your .emacs, either add it
+;; and then restart Emacs, or evaluate it just for this Emacs session
+;; by moving the cursor to just after the closing parenthesis and
+;; typing `C-x C-e'.
+
+;; (Note that if you _have_ already loaded GDS, and you type `C-x C-e'
+;; after this expression, you will see a *Guile Evaluation* window
+;; telling you that the evaluation failed because `require' is
+;; unbound. Don't worry; this is not a problem, and the rest of the
+;; tutorial should still work just fine.)
+
+;; ** Help
+
+;; GDS makes it easy to access the Guile help system when working on a
+;; Scheme program in Emacs. For example, suppose that you are writing
+;; code that uses list-ref, and need to remind yourself about
+;; list-ref's arguments ...
+
+(define (penultimate l)
+ (list-ref
+
+;; Just place the cursor on the word "list-ref" and type `C-h g RET'.
+;; Try it now!
+
+;; If GDS is working correctly, a window should have popped up above
+;; or below showing the Guile help for list-ref.
+
+;; You can also do an "apropos" search through Guile's help. If you
+;; couldn't remember the name list-ref, for example, you could search
+;; for anything matching "list" by typing `C-h C-g' and entering
+;; "list" at the minibuffer prompt. Try doing this now: you should
+;; see a longish list of Guile definitions whose names include "list".
+;; As usual in Emacs, you can use `M-PageUp' and `M-PageDown' to
+;; conveniently scroll the other window without having to select it.
+
+;; The functions called by `C-h g' and `C-h C-g' are gds-help-symbol
+;; and gds-apropos. They both look up the symbol or word at point by
+;; default, but that default can be overidden by typing something else
+;; at the minibuffer prompt.
+
+;; ** Completion
+
+;; As you are typing Scheme code, you can ask GDS to complete the
+;; symbol before point for you, by typing `ESC TAB'. GDS selects
+;; possible completions by matching the text so far against all
+;; definitions in the Guile environment. (This may be contrasted with
+;; the "dabbrev" completion performed by `M-/', which selects possible
+;; completions from the contents of Emacs buffers. So, if you are
+;; trying to complete "with-ou", to get "with-output-to-string", for
+;; example, `ESC TAB' will always work, because with-output-to-string
+;; is always defined in Guile's default environment, whereas `M-/'
+;; will only work if one of Emacs's buffers happens to contain the
+;; full name "with-output-to-string".)
+
+;; To illustrate the idea, here are some partial names that you can
+;; try completing. For each one, move the cursor to the end of the
+;; line and type `ESC TAB' to try to complete it.
+
+list-
+with-ou
+with-output-to-s
+mkst
+
+;; (If you are not familiar with any of the completed definitions,
+;; feel free to use `C-h g' to find out about them!)
+
+;; ** Evaluation
+
+;; GDS provides several ways for you to evaluate Scheme code from
+;; within Emacs.
+
+;; Just like in Emacs Lisp, a single expression in a buffer can be
+;; evaluated using `C-x C-e' or `C-M-x'. For `C-x C-e', the
+;; expression is that which ends immediately before point (so that it
+;; is useful for evaluating something just after you have typed it).
+;; For `C-M-x', the expression is the "top level defun" around point;
+;; this means the balanced chunk of code around point whose opening
+;; parenthesis is in column 0.
+
+;; Take this code fragment as an example:
+
+(let ((x 1) (y 2))
+ (let ((z (atan x y)))
+ (display "Arctangent is: ")
+ (display z)
+ (newline)
+ z))
+
+;; If you move the cursor to the end of the (display z) line and type
+;; `C-x C-e', the code evaluated is just "(display z)", which normally
+;; produces an error, because z is not defined in the usual Guile
+;; environment. If, however, you type `C-M-x' with the cursor in the
+;; same place, the code evaluated is the whole "(let ((x 1) (y 2))
+;; ...)" kaboodle, because that is the most recent expression before
+;; point that starts in column 0.
+
+;; Try these now. The Guile Evaluation window should pop up again,
+;; and show you:
+;; - the expression that was evaluated (probably abbreviated)
+;; - the module that it was evaluated in
+;; - anything that the code wrote to its standard output
+;; - the return value(s) of the evaluation.
+;; Following the convention of the Emacs Lisp and Guile manuals,
+;; return values are indicated by the symbol "=>".
+
+;; To see what happens when an expression has multiple return values,
+;; try evaluating this one:
+
+(values 'a (begin (display "hello world\n") 'b) 'c)
+
+;; You can also evaluate a region of a buffer using `C-c C-r'. If the
+;; code in the region consists of multiple expressions, GDS evaluates
+;; them sequentially. For example, try selecting the following three
+;; lines and typing `C-c C-r'.
+
+ (display "Arctangent is: ")
+ (display z)
+ (newline)
+
+;; If the code in the region evaluated isn't syntactically balanced,
+;; GDS will indicate a read error, for example for this code:
+
+ (let ((z (atan x y)))
+ (display "Arctangent is: ")
+ (display z)
+ (newline)
+
+;; Finally, if you want to evaluate something quickly that is not in a
+;; buffer, you can use `C-c C-e' and type the code to evaluate at the
+;; minibuffer prompt. The results are popped up in the same way as
+;; for code from a buffer.
+
+;; ** Breakpoints
+
+;; Before evaluating Scheme code from an Emacs buffer, you may want to
+;; set some breakpoints in it. With GDS you can set breakpoints in
+;; Scheme code by typing `C-x SPC'.
+;;
+;; To see how this works, select the second line of the following code
+;; (the `(format ...)' line) and type `C-x SPC'.
+
+(for-each (lambda (x)
+ (format #t "~A cubed is ~A\n" x (* x x x)))
+ (iota 6))
+
+;; The two opening parentheses in that line should now be highlighted
+;; in red, to show that breakpoints have been set at the start of the
+;; `(format ...)' and `(* x x x)' expressions. Then evaluate the
+;; whole for-each expression by typing `C-M-x' ...
+;;
+;; In the upper half of your Emacs, a buffer appears showing you the
+;; Scheme stack.
+;;
+;; In the lower half, the `(format ...)' expression is highlighted.
+;;
+;; What has happened is that Guile started evaluating the for-each
+;; code, but then hit the breakpoint that you set on the start of the
+;; format expression. Guile therefore pauses the evaluation at that
+;; point and passes the stack (which encapsulates everything that is
+;; interesting about the state of Guile at that point) to GDS. You
+;; can then explore the stack and decide how to tell Guile to
+;; continue.
+;;
+;; - If you move your mouse over any of the identifiers in the
+;; highlighted code, a help echo (or tooltip) will appear to tell
+;; you that identifier's current value. (Note though that this only
+;; works when the stack buffer is selected. So if you have switched
+;; to this buffer in order to scroll down and read these lines, you
+;; will need to switch back to the stack buffer before trying this
+;; out.)
+;;
+;; - In the stack buffer, the "=>" on the left shows you that the top
+;; frame is currently selected. You can move up and down the stack
+;; by pressing the up and down arrows (or `u' and `d'). As you do
+;; this, GDS will change the highlight in the lower window to show
+;; the code that corresponds to the selected stack frame.
+;;
+;; - You can evaluate an arbitrary expression in the local environment
+;; of the selected stack frame by typing `e' followed by the
+;; expression.
+;;
+;; - You can show various bits of information about the selected frame
+;; by typing `I', `A' and `S'. Feel free to try these now, to see
+;; what they do.
+;;
+;; You also have control over the continuing evaluation of this code.
+;; Here are some of the things you can do - please try them as you
+;; read.
+;;
+;; - `g' tells Guile to continue execution normally. In this case
+;; that means that evaluation will continue until it hits the next
+;; breakpoint, which is on the `(* x x x)' expression.
+;;
+;; - `SPC' tells Guile to continue until the next significant event in
+;; the same source file as the selected frame. A "significant
+;; event" means either beginning to evaluate an expression in the
+;; relevant file, or completing such an evaluation, in which case
+;; GDS tells you the value that it is returning. Pressing `SPC'
+;; repeatedly is a nice way to step through all the details of the
+;; code in a given file, but stepping over calls that involve code
+;; from other files.
+;;
+;; - `o' tells Guile to continue execution until the selected stack
+;; frame completes, and then to show its return value.
+
+;; Local Variables:
+;; mode: scheme
+;; End:
;; The subprocess object for the debug server.
(defvar gds-debug-server nil)
-(defvar gds-socket-type-alist '((tcp . 8333)
- (unix . "/tmp/.gds_socket"))
- "Maps each of the possible socket types that the GDS server can
-listen on to the path that it should bind to for each one.")
+(defvar gds-unix-socket-name (format "/tmp/.gds-socket-%d" (emacs-pid))
+ "Name of the Unix domain socket that GDS will listen on.")
+
+(defvar gds-tcp-port 8333
+ "The TCP port number that GDS will listen on.")
(defun gds-run-debug-server ()
"Start (or restart, if already running) the GDS debug server process."
(if gds-debug-server (gds-kill-debug-server))
(setq gds-debug-server
(gds-start-server "gds-debug"
- (cdr (assq gds-server-socket-type
- gds-socket-type-alist))
+ gds-unix-socket-name
+ gds-tcp-port
'gds-debug-protocol))
- (process-kill-without-query gds-debug-server))
+ (process-kill-without-query gds-debug-server)
+ ;; Add the Unix socket name to the environment, so that Guile
+ ;; clients started from within this Emacs will be able to use it,
+ ;; and thereby ensure that they connect to the GDS in this Emacs.
+ (setenv "GDS_UNIX_SOCKET_NAME" gds-unix-socket-name))
(defun gds-kill-debug-server ()
"Kill the GDS debug server process."
;;;; Debugger protocol
+(defcustom gds-protocol-hook nil
+ "Hook called on receipt of a protocol form from the GDS client."
+ :type 'hook
+ :group 'gds)
+
(defun gds-debug-protocol (client form)
+ (run-hook-with-args 'gds-protocol-hook form)
(or (eq client '*)
(let ((proc (car form)))
(cond ((eq proc 'name)
:group 'gds)
(defcustom gds-server-socket-type 'tcp
- "What kind of socket the GDS server should listen on."
+ "This option is now obsolete and has no effect."
:group 'gds
:type '(choice (const :tag "TCP" tcp)
(const :tag "Unix" unix)))
\
safe/README safe/safe safe/untrusted.scm safe/evil.scm
-AM_CFLAGS = `PATH=$(bindir):$$PATH PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config compile`
-AM_LIBS = `PATH=$(bindir):$$PATH PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config link`
+AM_CFLAGS = `PATH=$(bindir)$(PATH_SEPARATOR)$$PATH PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config compile`
+AM_LIBS = `PATH=$(bindir)$(PATH_SEPARATOR)$$PATH PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config link`
box/box: box/box.o
installcheck: box/box box-module/box libbox.la libbox-module.la
- LD_LIBRARY_PATH="$(libdir):$$LD_LIBRARY_PATH" \
- LTDL_LIBRARY_PATH="$(builddir):$$LTDL_LIBRARY_PATH" \
- GUILE_LOAD_PATH="$(abs_top_srcdir):$$GUILE_LOAD_PATH" \
- PATH="$(bindir):$$PATH" \
+ LD_LIBRARY_PATH="$(libdir)$(PATH_SEPARATOR)$$LD_LIBRARY_PATH" \
+ LTDL_LIBRARY_PATH="$(builddir)$(PATH_SEPARATOR)$$LTDL_LIBRARY_PATH" \
+ GUILE_LOAD_PATH="$(abs_top_srcdir)$(PATH_SEPARATOR)$$GUILE_LOAD_PATH" \
+ PATH="$(bindir)$(PATH_SEPARATOR)$$PATH" \
GUILE_AUTO_COMPILE=0 \
srcdir="$(srcdir)" \
$(srcdir)/check.test
ac_cv_have_scm_t_bits=no)])
AC_MSG_RESULT($ac_cv_have_scm_t_bits)
if test $ac_cv_have_scm_t_bits = yes; then
- AC_DEFINE(HAVE_SCM_T_BITS)
+ AC_DEFINE([HAVE_SCM_T_BITS])
fi
LIBS="$guile_compat_save_LIBS"
CFLAGS="$guile_compat_save_CFLAGS"])
(let () (begin (set! make-fasl (lambda (.infilename|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 (if (not (null? .rest|1)) (let ((.x|8|11 .rest|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (rewrite-file-type .infilename|1 *lop-file-type* *fasl-file-type*)))) (begin (process-file .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.x|7) .x|7)) (unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) (error "Make-fasl not supported on this target architecture.") (.doit|2)))))) 'make-fasl))
(let () (begin (set! disassemble (lambda (.item|1 . .rest|1) (let ((.output-port|4 (if (null? .rest|1) (current-output-port) (let ((.x|5|8 .rest|1)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8)))))) (begin (disassemble-item .item|1 #f .output-port|4) (unspecified))))) 'disassemble))
(let () (begin (set! disassemble-item (lambda (.item|1 .segment-no|1 .port|1) (let ((.disassemble-item|2 0)) (begin (set! .disassemble-item|2 (lambda (.item|3 .segment-no|3 .port|3) (let ((.print-segment|5 (unspecified)) (.print-constvector|5 (unspecified)) (.print|5 (unspecified))) (begin (set! .print-segment|5 (lambda (.segment|6) (begin (.print|5 "Segment # " .segment-no|3) (print-instructions (disassemble-codevector (let ((.x|7|10 .segment|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) .port|3) (.print-constvector|5 (let ((.x|11|14 .segment|6)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) (.print|5 "========================================")))) (set! .print-constvector|5 (lambda (.cv|15) (let () (let ((.loop|17|19|22 (unspecified))) (begin (set! .loop|17|19|22 (lambda (.i|23) (if (= .i|23 (let ((.v|25|28 .cv|15)) (begin (.check! (vector? .v|25|28) 42 .v|25|28) (vector-length:vec .v|25|28)))) (if #f #f (unspecified)) (begin (begin #t (.print|5 "------------------------------------------") (.print|5 "Constant vector element # " .i|23) (let ((.temp|30|33 (let ((.x|90|93 (let ((.v|94|97 .cv|15) (.i|94|97 .i|23)) (begin (.check! (fixnum? .i|94|97) 40 .v|94|97 .i|94|97) (.check! (vector? .v|94|97) 40 .v|94|97 .i|94|97) (.check! (<:fix:fix .i|94|97 (vector-length:vec .v|94|97)) 40 .v|94|97 .i|94|97) (.check! (>=:fix:fix .i|94|97 0) 40 .v|94|97 .i|94|97) (vector-ref:trusted .v|94|97 .i|94|97))))) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93))))) (if (memv .temp|30|33 '(codevector)) (begin (.print|5 "Code vector") (print-instructions (disassemble-codevector (let ((.x|36|39 (let ((.x|40|43 (let ((.v|44|47 .cv|15) (.i|44|47 .i|23)) (begin (.check! (fixnum? .i|44|47) 40 .v|44|47 .i|44|47) (.check! (vector? .v|44|47) 40 .v|44|47 .i|44|47) (.check! (<:fix:fix .i|44|47 (vector-length:vec .v|44|47)) 40 .v|44|47 .i|44|47) (.check! (>=:fix:fix .i|44|47 0) 40 .v|44|47 .i|44|47) (vector-ref:trusted .v|44|47 .i|44|47))))) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39)))) .port|3)) (if (memv .temp|30|33 '(constantvector)) (begin (.print|5 "Constant vector") (.print-constvector|5 (let ((.x|50|53 (let ((.x|54|57 (let ((.v|58|61 .cv|15) (.i|58|61 .i|23)) (begin (.check! (fixnum? .i|58|61) 40 .v|58|61 .i|58|61) (.check! (vector? .v|58|61) 40 .v|58|61 .i|58|61) (.check! (<:fix:fix .i|58|61 (vector-length:vec .v|58|61)) 40 .v|58|61 .i|58|61) (.check! (>=:fix:fix .i|58|61 0) 40 .v|58|61 .i|58|61) (vector-ref:trusted .v|58|61 .i|58|61))))) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))))) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv .temp|30|33 '(global)) (.print|5 "Global: " (let ((.x|64|67 (let ((.x|68|71 (let ((.v|72|75 .cv|15) (.i|72|75 .i|23)) (begin (.check! (fixnum? .i|72|75) 40 .v|72|75 .i|72|75) (.check! (vector? .v|72|75) 40 .v|72|75 .i|72|75) (.check! (<:fix:fix .i|72|75 (vector-length:vec .v|72|75)) 40 .v|72|75 .i|72|75) (.check! (>=:fix:fix .i|72|75 0) 40 .v|72|75 .i|72|75) (vector-ref:trusted .v|72|75 .i|72|75))))) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71))))) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67)))) (if (memv .temp|30|33 '(data)) (.print|5 "Data: " (let ((.x|78|81 (let ((.x|82|85 (let ((.v|86|89 .cv|15) (.i|86|89 .i|23)) (begin (.check! (fixnum? .i|86|89) 40 .v|86|89 .i|86|89) (.check! (vector? .v|86|89) 40 .v|86|89 .i|86|89) (.check! (<:fix:fix .i|86|89 (vector-length:vec .v|86|89)) 40 .v|86|89 .i|86|89) (.check! (>=:fix:fix .i|86|89 0) 40 .v|86|89 .i|86|89) (vector-ref:trusted .v|86|89 .i|86|89))))) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (unspecified))))))) (.loop|17|19|22 (+ .i|23 1)))))) (.loop|17|19|22 0)))))) (set! .print|5 (lambda .rest|98 (begin (let () (let ((.loop|104|106|109 (unspecified))) (begin (set! .loop|104|106|109 (lambda (.y1|99|100|110) (if (null? .y1|99|100|110) (if #f #f (unspecified)) (begin (begin #t (let ((.x|114 (let ((.x|115|118 .y1|99|100|110)) (begin (.check! (pair? .x|115|118) 0 .x|115|118) (car:pair .x|115|118))))) (display .x|114 .port|3))) (.loop|104|106|109 (let ((.x|119|122 .y1|99|100|110)) (begin (.check! (pair? .x|119|122) 1 .x|119|122) (cdr:pair .x|119|122)))))))) (.loop|104|106|109 .rest|98)))) (newline .port|3)))) (if (procedure? .item|3) (print-instructions (disassemble-codevector (procedure-ref .item|3 0)) .port|3) (if (if (pair? .item|3) (if (bytevector? (let ((.x|126|129 .item|3)) (begin (.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129)))) (vector? (let ((.x|131|134 .item|3)) (begin (.check! (pair? .x|131|134) 1 .x|131|134) (cdr:pair .x|131|134)))) #f) #f) (.print-segment|5 .item|3) (error "disassemble-item: " .item|3 " is not disassemblable."))))))) (.disassemble-item|2 .item|1 .segment-no|1 .port|1))))) 'disassemble-item))
-(let () (begin (set! disassemble-file (lambda (.file|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda (.input-port|3 .output-port|3) (begin (display "\; From " .output-port|3) (display .file|1 .output-port|3) (newline .output-port|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment-no|12 .segment|12) (if (eof-object? .segment|12) (if #f #f (unspecified)) (begin (begin #t (disassemble-item .segment|12 .segment-no|12 .output-port|3)) (.loop|5|8|11 (+ .segment-no|12 1) (read .input-port|3)))))) (.loop|5|8|11 0 (read .input-port|3)))))))) (call-with-input-file .file|1 (lambda (.input-port|15) (if (null? .rest|1) (.doit|2 .input-port|15 (current-output-port)) (begin (delete-file (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) (call-with-output-file (let ((.x|20|23 .rest|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (lambda (.output-port|24) (.doit|2 .input-port|15 .output-port|24))))))) (unspecified))))) 'disassemble-file))
+(let () (begin (set! disassemble-file (lambda (.file|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda (.input-port|3 .output-port|3) (begin (display "; From " .output-port|3) (display .file|1 .output-port|3) (newline .output-port|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment-no|12 .segment|12) (if (eof-object? .segment|12) (if #f #f (unspecified)) (begin (begin #t (disassemble-item .segment|12 .segment-no|12 .output-port|3)) (.loop|5|8|11 (+ .segment-no|12 1) (read .input-port|3)))))) (.loop|5|8|11 0 (read .input-port|3)))))))) (call-with-input-file .file|1 (lambda (.input-port|15) (if (null? .rest|1) (.doit|2 .input-port|15 (current-output-port)) (begin (delete-file (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) (call-with-output-file (let ((.x|20|23 .rest|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (lambda (.output-port|24) (.doit|2 .input-port|15 .output-port|24))))))) (unspecified))))) 'disassemble-file))
(let () (begin (set! compiler-switches (lambda .rest|1 (let ((.fast-unsafe-code|3 (unspecified)) (.fast-safe-code|3 (unspecified)) (.standard-code|3 (unspecified)) (.slow-code|3 (unspecified))) (begin (set! .fast-unsafe-code|3 (lambda () (begin (set-compiler-flags! 'fast-unsafe) (set-assembler-flags! 'fast-unsafe)))) (set! .fast-safe-code|3 (lambda () (begin (set-compiler-flags! 'fast-safe) (set-assembler-flags! 'fast-safe)))) (set! .standard-code|3 (lambda () (begin (set-compiler-flags! 'standard) (set-assembler-flags! 'standard)))) (set! .slow-code|3 (lambda () (begin (set-compiler-flags! 'no-optimization) (set-assembler-flags! 'no-optimization)))) (if (null? .rest|1) (begin (display "Debugging:") (newline) (display-twobit-flags 'debugging) (display-assembler-flags 'debugging) (newline) (display "Safety:") (newline) (display-twobit-flags 'safety) (display-assembler-flags 'safety) (newline) (display "Speed:") (newline) (display-twobit-flags 'optimization) (display-assembler-flags 'optimization) (if #f #f (unspecified))) (if (null? (let ((.x|9|12 .rest|1)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12)))) (begin (let ((.temp|13|16 (let ((.x|27|30 .rest|1)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (if (memv .temp|13|16 '(0 slow)) (.slow-code|3) (if (memv .temp|13|16 '(1 standard)) (.standard-code|3) (if (memv .temp|13|16 '(2 fast-safe)) (.fast-safe-code|3) (if (memv .temp|13|16 '(3 fast-unsafe)) (.fast-unsafe-code|3) (if (memv .temp|13|16 '(default factory-settings)) (begin (.fast-safe-code|3) (include-source-code #t) (benchmark-mode #f) (benchmark-block-mode #f) (common-subexpression-elimination #f) (representation-inference #f)) (error "Unrecognized flag " (let ((.x|23|26 .rest|1)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))) " to compiler-switches."))))))) (unspecified)) (error "Too many arguments to compiler-switches."))))))) 'compiler-switches))
(let () (begin (set! process-file (lambda (.infilename|1 .outfilename|1 .writer|1 .processer|1) (let ((.process-file|2 0)) (begin (set! .process-file|2 (lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) (let ((.x|12 (read .inport|9))) (let () (let ((.loop|15 (unspecified))) (begin (set! .loop|15 (lambda (.x|16) (if (eof-object? .x|16) #t (begin (.writer|3 (.processer|3 .x|16) .outport|8) (.loop|15 (read .inport|9)))))) (.loop|15 .x|12)))))))))))) (let ((.current-syntactic-environment|17 (syntactic-copy global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () (.doit|6)) (lambda () (set! global-syntactic-environment .current-syntactic-environment|17)))))))) (.process-file|2 .infilename|1 .outfilename|1 .writer|1 .processer|1))))) 'process-file))
(let () (begin (set! process-file-block (lambda (.infilename|1 .outfilename|1 .writer|1 .processer|1) (let ((.process-file-block|2 0)) (begin (set! .process-file-block|2 (lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.x|17 .forms|17) (if (eof-object? .x|17) (.writer|3 (.processer|3 (reverse .forms|17)) .outport|8) (begin #t (.loop|10|13|16 (read .inport|9) (cons .x|17 .forms|17)))))) (.loop|10|13|16 (read .inport|9) '()))))))))))) (let ((.current-syntactic-environment|20 (syntactic-copy global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () (.doit|6)) (lambda () (set! global-syntactic-environment .current-syntactic-environment|20)))))))) (.process-file-block|2 .infilename|1 .outfilename|1 .writer|1 .processer|1))))) 'process-file-block))
-c '(apply main (cdr (command-line)))' \
--benchmark-dir="$(dirname $0)" "$@"
!#
-;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
(ice-9 popen)
(ice-9 regex)
(ice-9 format)
+ (ice-9 pretty-print)
(srfi srfi-1)
(srfi srfi-37))
result)))
(define (pretty-print-result benchmark reference bdwgc)
+ (define ref-heap (assoc-ref reference 'heap-size))
+ (define ref-time (assoc-ref reference 'execution-time))
+
+ (define (distance x1 y1 x2 y2)
+ ;; Return the distance between (X1,Y1) and (X2,Y2). Y is the heap size,
+ ;; in MiB and X is the execution time in seconds.
+ (let ((y1 (/ y1 (expt 2 20)))
+ (y2 (/ y2 (expt 2 20))))
+ (sqrt (+ (expt (- y1 y2) 2)
+ (expt (- x1 x2) 2)))))
+
+ (define (score time heap)
+ ;; Return a score lower than +1.0. The score is positive if the
+ ;; distance to the origin of (TIME,HEAP) is smaller than that of
+ ;; (REF-TIME,REF-HEAP), negative otherwise.
+
+ ;; heap ^ .
+ ;; size | . worse
+ ;; | . [-]
+ ;; | .
+ ;; | . . . .ref. . . .
+ ;; | .
+ ;; | [+] .
+ ;; | better .
+ ;; 0 +-------------------->
+ ;; exec. time
+
+ (let ((ref-dist (distance ref-time ref-heap 0 0))
+ (dist (distance time heap 0 0)))
+ (/ (- ref-dist dist) ref-dist)))
+
+ (define (score-string time heap)
+ ;; Return a string denoting a bar to illustrate the score of (TIME,HEAP)
+ ;; relative to (REF-TIME,REF-HEAP).
+ (define %max-width 15)
+
+ (let ((s (score time heap)))
+ (make-string (inexact->exact (round (* (if (< s 0.0) (- s) s)
+ %max-width)))
+ (if (< s 0.0)
+ #\-
+ #\+))))
+
(define (print-line name result ref?)
- (let ((name (string-pad-right name 23))
- (time (assoc-ref result 'execution-time))
- (heap (assoc-ref result 'heap-size))
- (ref-heap (assoc-ref reference 'heap-size))
- (ref-time (assoc-ref reference 'execution-time)))
- (format #t "~a ~1,2f (~,2fx) ~6,3f (~,2fx)~A~%"
+ (let ((name (string-pad-right name 23))
+ (time (assoc-ref result 'execution-time))
+ (heap (assoc-ref result 'heap-size)))
+ (format #t "~a ~6,2f (~,2fx) ~7,3f (~,2fx)~A~%"
name
- (/ heap 1000000.0) (/ heap ref-heap 1.0)
+ (/ heap (expt 2.0 20)) (/ heap ref-heap 1.0)
time (/ time ref-time 1.0)
- (if (and (not ref?)
- (<= heap ref-heap) (<= time ref-time))
- " !"
+ (if (not ref?)
+ (string-append " "
+ (score-string time heap))
""))))
(format #t "benchmark: `~a'~%" benchmark)
- (format #t " heap size (MiB) execution time (s.)~%")
+ (format #t " heap size (MiB) execution time (s.)~%")
(print-line "Guile" reference #t)
(for-each (lambda (bdwgc)
(let ((name (format #f "BDW-GC, FSD=~a~a"
(print-line name bdwgc #f)))
bdwgc))
+(define (print-raw-result benchmark reference bdwgc)
+ (pretty-print `(,benchmark
+ (reference . ,reference)
+ (bdw-gc . ,bdwgc))))
+
+
\f
;;;
;;; Option processing.
(lambda (opt name arg result)
(alist-cons 'log-port (open-output-file arg)
(alist-delete 'log-port result
- eq?))))))
+ eq?))))
+ (option '("raw") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'printer print-raw-result
+ (alist-delete 'printer result eq?))))
+ (option '("load-results") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'load-results? #t result)))))
(define %default-options
`((reference-environment . "GUILE=guile")
(benchmark-directory . "./gc-benchmarks")
(log-port . ,(current-output-port))
(profile-options . "")
- (input . ())))
+ (input . ())
+ (printer . ,pretty-print-result)))
(define (show-help)
(format #t "Usage: run-benchmark [OPTIONS] BENCHMARKS...
Pass OPTS as additional options for `gc-profile.scm'.
-l, --log-file=FILE
Save output to FILE instead of the standard output.
+
+ --raw Write benchmark results in raw (s-exp) format.
+ --load-results
+ Load raw (s-exp) results instead of actually running
+ the benchmarks.
+
-d, --benchmark-dir=DIR
Use DIR as the GC benchmark directory where `gc-profile.scm'
lives (it is automatically determined by default).
(bdwgc-env (or (assoc-ref args 'bdwgc-environment)
(string-append "GUILE=" bench-dir
"/../meta/guile")))
- (prof-opts (assoc-ref args 'profile-options)))
- (for-each (lambda (benchmark)
- (let ((ref (parse-result (run-reference-guile ref-env
- bench-dir
- prof-opts
- benchmark)))
- (bdwgc (map (lambda (fsd incremental?
- generational? parallel?)
- (let ((opts
- (list
- (cons 'free-space-divisor fsd)
- (cons 'incremental? incremental?)
- (cons 'generational? generational?)
- (cons 'parallel? parallel?))))
- (append opts
- (parse-result
- (run-bdwgc-guile bdwgc-env
- bench-dir
- prof-opts
- opts
- benchmark)))))
- '( 3 6 9 3 3)
- '(#f #f #f #t #f) ;; incremental
- '(#f #f #f #f #t) ;; generational
- '(#f #f #f #f #f)))) ;; parallel
- ;;(format #t "ref=~A~%" ref)
- ;;(format #t "bdw-gc=~A~%" bdwgc)
+ (prof-opts (assoc-ref args 'profile-options))
+ (print (assoc-ref args 'printer)))
+ (define (run benchmark)
+ (let ((ref (parse-result (run-reference-guile ref-env
+ bench-dir
+ prof-opts
+ benchmark)))
+ (bdwgc (map (lambda (fsd incremental?
+ generational? parallel?)
+ (let ((opts
+ (list
+ (cons 'free-space-divisor fsd)
+ (cons 'incremental? incremental?)
+ (cons 'generational? generational?)
+ (cons 'parallel? parallel?))))
+ (append opts
+ (parse-result
+ (run-bdwgc-guile bdwgc-env
+ bench-dir
+ prof-opts
+ opts
+ benchmark)))))
+ '( 3 6 9 3 3)
+ '(#f #f #f #t #f) ;; incremental
+ '(#f #f #f #f #t) ;; generational
+ '(#f #f #f #f #f)))) ;; parallel
+ `(,benchmark
+ (reference . ,ref)
+ (bdw-gc . ,bdwgc))))
+
+ (define (load-results file)
+ (with-input-from-file file
+ (lambda ()
+ (let loop ((results '()) (o (read)))
+ (if (eof-object? o)
+ (reverse results)
+ (loop (cons o results)
+ (read)))))))
+
+ (for-each (lambda (result)
+ (let ((benchmark (car result))
+ (ref (assoc-ref (cdr result) 'reference))
+ (bdwgc (assoc-ref (cdr result) 'bdw-gc)))
(with-output-to-port log
(lambda ()
- (pretty-print-result benchmark ref bdwgc)
+ (print benchmark ref bdwgc)
(newline)
(force-output)))))
- benchmark-files))))
+ (if (assoc-ref args 'load-results?)
+ (append-map load-results benchmark-files)
+ (map run benchmark-files))))))
# -*- GDB-Script -*-
+handle SIGPWR noprint nostop
+handle SIGXCPU noprint nostop
+
define newline
call (void)scm_newline (scm_current_error_port ())
end
define inst
p scm_instruction_table[$arg0]
end
+
+define gbt
+ call scm_display_backtrace (scm_make_stack(0x404,0x304), scm_current_error_port (), 0x704, 0x704, 0x704)
+end
;;;; readline.scm --- support functions for command-line editing
;;;;
-;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
\f
(define-module (ice-9 readline)
- :use-module (ice-9 session)
- :use-module (ice-9 regex)
- :use-module (ice-9 buffered-input)
- :no-backtrace
- :export (filename-completion-function))
+ #:use-module (ice-9 session)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 buffered-input)
+ #:no-backtrace
+ #:export (filename-completion-function
+ add-history
+ read-history
+ write-history
+ clear-history))
\f
(let ((repl-read-hook (lambda () (run-hook before-read-hook))))
(set-current-input-port (readline-port))
(set! repl-reader
- (lambda (repl-prompt)
+ (lambda (repl-prompt . reader)
(let ((outer-new-input-prompt new-input-prompt)
(outer-continuation-prompt continuation-prompt)
(outer-read-hook read-hook))
(set-buffered-input-continuation?! (readline-port) #f)
(set-readline-prompt! repl-prompt "... ")
(set-readline-read-hook! repl-read-hook))
- (lambda () ((or (fluid-ref current-reader) read)))
+ (lambda () ((or (and (pair? reader) (car reader))
+ (fluid-ref current-reader)
+ read)))
(lambda ()
(set-readline-prompt! outer-new-input-prompt outer-continuation-prompt)
(set-readline-read-hook! outer-read-hook))))))
static int promptp;
static SCM input_port;
+static SCM output_port;
static SCM before_read;
static int
scm_apply (before_read, SCM_EOL, SCM_EOL);
promptp = 0;
}
- return scm_getc (input_port);
+ return scm_get_byte_or_eof (input_port);
}
static int in_readline = 0;
promptp = 1;
s = readline (prompt);
if (s)
- ret = scm_from_locale_string (s);
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (output_port);
+
+ ret = scm_from_stringn (s, strlen (s), pt->encoding,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ }
else
ret = SCM_EOF_VAL;
}
input_port = inp;
+ output_port = outp;
#ifndef __MINGW32__
rl_instream = stream_from_fport (inp, "r", s_scm_readline);
rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
rl_basic_word_break_characters = "\t\n\"'`;()";
rl_readline_name = "Guile";
- reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ());
+ reentry_barrier_mutex = scm_make_mutex ();
scm_init_opts (scm_readline_options,
scm_readline_opts);
#if HAVE_RL_GET_KEYMAP
+++ /dev/null
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 2000, 2006, 2009 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE 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, or
-## (at your option) any later version.
-##
-## GUILE 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 GUILE; see the file COPYING.LESSER. If not,
-## write to the Free Software Foundation, Inc., 51 Franklin Street,
-## Fifth Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-# These should be installed and distributed.
-
-elisp_sources = \
- elisp/base.scm \
- elisp/example.el \
- elisp/interface.scm \
- elisp/transform.scm \
- elisp/expand.scm \
- elisp/variables.scm \
- \
- elisp/primitives/buffers.scm \
- elisp/primitives/char-table.scm \
- elisp/primitives/features.scm \
- elisp/primitives/fns.scm \
- elisp/primitives/format.scm \
- elisp/primitives/guile.scm \
- elisp/primitives/keymaps.scm \
- elisp/primitives/lists.scm \
- elisp/primitives/load.scm \
- elisp/primitives/match.scm \
- elisp/primitives/numbers.scm \
- elisp/primitives/pure.scm \
- elisp/primitives/read.scm \
- elisp/primitives/signal.scm \
- elisp/primitives/strings.scm \
- elisp/primitives/symprop.scm \
- elisp/primitives/syntax.scm \
- elisp/primitives/system.scm \
- elisp/primitives/time.scm \
- \
- elisp/internals/evaluation.scm \
- elisp/internals/format.scm \
- elisp/internals/fset.scm \
- elisp/internals/lambda.scm \
- elisp/internals/load.scm \
- elisp/internals/null.scm \
- elisp/internals/set.scm \
- elisp/internals/signal.scm \
- elisp/internals/time.scm \
- elisp/internals/trace.scm
-
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang
-nobase_subpkgdata_DATA = $(elisp_sources)
-TAGS_FILES = $(nobase_subpkgdata_DATA)
-
-EXTRA_DIST = $(elisp_sources) elisp/ChangeLog-2008
+++ /dev/null
-2008-04-14 Neil Jerram <neil@ossau.uklinux.net>
-
- * primitives/symprop.scm (get): Use lambda->nil.
-
- * primitives/strings.scm (aset): New primitive.
-
- * internals/load.scm (load): Use in-vicinity (instead of
- string-append) to add a slash if needed.
-
-2004-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
-
- * primitives/Makefile.am (TAGS_FILES), internals/Makefile.am
- (TAGS_FILES), Makefile.am (TAGS_FILES): Use this variable instead
- of ETAGS_ARGS so that TAGS can be built using separate build
- directory.
-
-2003-11-01 Neil Jerram <neil@ossau.uklinux.net>
-
- * internals/format.scm (format), internals/signal.scm (error),
- internals/load.scm (load): Export using #:replace to avoid
- duplicate binding warnings.
-
-2003-01-05 Marius Vollmer <mvo@zagadka.ping.de>
-
- * primitives/Makefile.am (elisp_sources): Added char-table.scm.
-
-2002-12-28 Neil Jerram <neil@ossau.uklinux.net>
-
- * base.scm (lang): Use char-table module.
-
- * primitives/char-table.scm (lang): New (stub definitions).
-
-2002-12-08 Rob Browning <rlb@defaultvalue.org>
-
- * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
-
- * primitives/Makefile.am (subpkgdatadir): VERSION ->
- GUILE_EFFECTIVE_VERSION.
-
- * internals/Makefile.am (subpkgdatadir): VERSION ->
- GUILE_EFFECTIVE_VERSION.
-
-2002-02-13 Neil Jerram <neil@ossau.uklinux.net>
-
- * base.scm (load-emacs): Add optional parameters for specifying an
- alternative load path, and for debugging this. (Thanks to
- Thien-Thi Nguyen!)
-
- * primitives/syntax.scm (setq): Use `set'.
-
- * internals/set.scm (set): Fixed to support variables that are
- imported from other modules.
-
-2002-02-12 Neil Jerram <neil@ossau.uklinux.net>
-
- * transform.scm (scheme): Use set-current-module to ensure
- expected behaviour of resolve-module.
-
-2002-02-08 Neil Jerram <neil@ossau.uklinux.net>
-
- * STATUS: New file.
-
- * README: Updated.
-
- * interface.scm (translate-elisp): New exported procedure.
- (elisp-function): Symbol var is `obj', not `symbol'.
-
- * internals/lambda.scm, primitives/fns.scm: Fix confusion between
- interactive-spec and interactive-specification.
-
- * internals/lambda.scm (transform-lambda), primitives/syntax.scm
- (defmacro): Bind unspecified optional and rest arguments to #nil,
- not #f.
-
- * internals/null.scm (->nil, lambda->nil): New, exported.
- (null): Use ->nil.
-
- * primitives/features.scm (featurep), primitives/fns.scm
- (fboundp, subrp): Use ->nil.
-
- * internals/lists.scm (cons, setcdr, memq, member, assq, assoc):
- Simplified.
- (car, cdr): Return #nil rather than #f.
-
- * primitives/load.scm (current-load-list), primitives/pure.scm
- (purify-flag): Set to #nil, not #f.
-
- * primitives/match.scm (string-match): Return #nil rather than #f.
-
- * primitives/numbers.scm (integerp, numberp),
- primitives/strings.scm (string-lessp, stringp): Use lambda->nil.
-
- * primitives/symprop.scm (boundp): Use ->nil.
- (symbolp, local-variable-if-set-p): Return #nil rather than #f.
-
- * primitives/syntax.scm (prog1, prog2): Mangle variable names
- further to lessen possibility of conflicts.
- (if, and, or, cond): Return #nil rather than #f.
- (cond): Return #t rather than t (which is undefined).
- (let, let*): Bind uninitialized variables to #nil, not #f.
-
- * transform.scm: Resolve inconsistency in usage of `map', and add
- an explanatory note. Also cleaned up use of subsidiary
- transformation functions. Also use cons-source wherever possible.
- (transform-datum, transform-quote): New.
- (transform-quasiquote): Renamed from `transform-inside-qq'.
- (transform-application): Apply `transform-quote' to application
- args.
- (cars->nil): Removed.
-
- * internals/null.scm (null), primitives/lists.scm (cons, car, cdr,
- setcdr, memq, member, assq, assoc, nth): Update to take into
- account new libguile support for Elisp nil value.
-
-2002-02-06 Neil Jerram <neil@ossau.uklinux.net>
-
- * example.el (time): New macro, for performance measurement.
- Accompanying comment compares results for Guile and Emacs.
-
- * transform.scm (scheme): New macro.
- (transformer): New implementation of `scheme' escape that doesn't
- rely on (lang elisp base) importing Guile bindings.
-
- * base.scm: No longer import anything from (guile).
- (load-emacs): Add scheme form to ensure that keywords
- read option is set correctly.
-
- * primitives/syntax.scm (defmacro, let, let*): Unquote uses of
- `@bind' in transformed code.
- (if): Unquote uses of `nil-cond' in transformed code.
-
- * internals/lambda.scm (transform-lambda): Unquote use of `@bind'
- in transformed code.
-
- * transform.scm (transformer-macro): Don't quote `list' in
- transformed code.
- (transform-application): Don't quote `@fop' in transformed code.
- (transformer): No need to treat `@bind' and `@fop' as special
- cases in input to the transformer.
-
-2002-02-04 Neil Jerram <neil@ossau.uklinux.net>
-
- * primitives/syntax.scm (parse-formals, transform-lambda,
- interactive-spec, set-not-subr!, transform-lambda/interactive):
- Move into internals/lambda.scm so that these can also be used
- by...
-
- * internals/fset.scm (elisp-apply): Use `eval' and
- `transform-lambda/interactive' to turn a quoted lambda expression
- into a Scheme procedure.
-
- * transform.scm (m-quasiquote): Don't quote `quasiquote' in
- transformed code.
- (transformer): Transform '() to #nil.
-
-2002-02-03 Neil Jerram <neil@ossau.uklinux.net>
-
- * internals/Makefile.am (elisp_sources): Add lambda.scm.
-
- * internals/lambda.scm (lang): New file.
-
-2002-02-01 Neil Jerram <neil@ossau.uklinux.net>
-
- * transform.scm (transformer), primitives/syntax.scm (let*):
- Unquote uses of `begin' in transformed code.
-
-2002-01-29 Neil Jerram <neil@ossau.uklinux.net>
-
- * transform.scm (transform-1, transform-2, transform-3,
- transform-list): Removed (unused).
-
- * transform.scm, primitives/syntax.scm: Add commas everywhere
- before use of (guile) primitives in generated code, so that (lang
- elisp base) doesn't have to import bindings from (guile).
-
- * base.scm: Move use-modules expressions inside the define-module,
- and add #:pure so that we don't import bindings from (guile).
-
-2002-01-25 Neil Jerram <neil@ossau.uklinux.net>
-
- * transform.scm (transform-application): Preserve source
- properties of original elisp expression by using cons-source.
-
- * transform.scm: Don't handle special forms specially in the
- translator. Instead, define them as macros in ...
-
- * primitives/syntax.scm: New file; special form definitions.
-
- * primitives/fns.scm (run-hooks): Rewritten correctly.
-
- * primitives/symprop.scm (symbol-value): Use `value'.
-
- * internals/set.scm (value): New function.
-
- * primitives/fns.scm: Use (lang elisp internals null), as null is
- no longer a primitive. Change generated #f values to %nil.
-
- * internals/null.scm (null): Handle nil symbol.
-
- * primitives/lists.scm (memq, member, assq, assoc): Handle all
- possible nil values.
-
- * transform.scm (transformer): Translate `nil' and `t' to #nil and
- #t.
-
- * base.scm: Remove setting of 'language read-option.
-
-2001-11-03 Neil Jerram <neil@ossau.uklinux.net>
-
- * README (Resources): Fill in missing URLs.
-
-2001-11-02 Neil Jerram <neil@ossau.uklinux.net>
-
- * Makefile.am (elisp_sources): Added base.scm, example.el,
- interface.scm; removed emacs.scm.
-
- * README: Updated accordingly.
-
- * internals/load.scm (load): Avoid using `load-path' if the
- supplied file name begins with a slash.
-
- * internals/fset.scm: Support export of defuns, defmacros and
- defvars to a module specified by the fluid `elisp-export-module'.
- This allows us to automate the importing of Elisp definitions into
- Scheme.
-
- * example.el: New file: example code for `load-elisp-file'.
-
- * interface.scm: New file - mechanisms to exchange definitions
- between Scheme and Elisp.
-
- Following changes try to make the Elisp evaluation module less
- Emacs-dependent; in other words, so that it isn't necessary to try
- to load the whole Emacs environment before evaluating basic
- non-Emacs-specific Elisp code.
-
- * variables.scm, internals/evaluation.scm: Changed (lang elisp
- emacs) to (lang elisp base).
-
- * emacs.scm (lang): Removed.
-
- * base.scm (lang): New file (non-emacs-specific replacement for
- emacs.scm).
-
-2001-10-28 Neil Jerram <neil@ossau.uklinux.net>
-
- * primitives/symprop.scm (symbol-name): New primitive.
-
- * primitives/strings.scm (stringp): New primitive.
-
- * primitives/pure.scm (purify-flag): New variable.
-
- * primitives/numbers.scm (numberp): New primitive.
-
- * internals/fset.scm (fset): Set procedure and macro name
- properties usefully to match Elisp symbol names. Also bind Elisp
- function definition variables to similarly named symbols in the
- (lang elisp variables) module.
-
- * transform.scm (transformer, m-unwind-protect): Added support for
- `unwind-protect'.
- (m-quasiquote): Use 'quasiquote rather than 'quote.
- (transform-lambda, m-defmacro): When no rest arguments, set the
- rest parameter to '() rather than #f. It shouldn't make any
- difference, but it feels more right.
-
- * README: Enlarged description of current status.
-
- * Makefile.am (elisp_sources): Added variables.scm.
-
- * variables.scm: New file.
-
-2001-10-26 Neil Jerram <neil@ossau.uklinux.net>
-
- * buffers.scm, calling.scm: Removed. These should have
- disappeared during the reorganization described below, but I
- missed them by mistake.
-
- * primitives/symprop.scm (set, boundp, symbol-value): Changed to
- use (module-xx the-elisp-module ...) rather than (local-xx ...).
- (symbolp): Accept either symbols or keywords.
- (set-default, default-boundp, default-value,
- local-variable-if-set-p): New.
-
- * primitives/match.scm (string-match, match-data): Store last
- match data in Emacs rather than Guile form, to simplify
- implementation of ...
- (set-match-data, store-match-data): New.
-
- * primitives/load.scm (autoload, current-load-list): New. (But
- autoload is just stubbed, not properly implemented.)
-
- * primitives/lists.scm (nth, listp, consp, nconc): New.
-
- * primitives/fns.scm (byte-code-function-p, run-hooks): New.
-
- * transform.scm (transform-application, transformer-macro): New
- scheme for transforming procedure arguments while leaving macro
- args untransformed. (See also associated change in libguile.)
- (m-defconst): Simplified, now uses m-setq.
-
- * Makefile.am: Changed so that it only deals with files directly
- in this directory; otherwise files don't install cleanly.
-
- * internals/Makefile.am, primitives/Makefile.am,
- internals/.cvsignore, primitives/.cvsignore: New files.
-
-2001-10-26 Neil Jerram <neil@ossau.uklinux.net>
-
- * transform.scm (transformer): New handling for (1) quasiquoting
- syntax like "(` ...)" as well as the more normal "` ..."; (2)
- `function'; (3) interactive specification in lambda body.
- Simplied handling for `setq'.
- (transform-inside-qq): Fixed to handle improper as well as proper
- lists.
- (transform-lambda/interactive): New; wraps transform-lambda to
- handle setting of various procedure properties.
- (transform-lambda, m-defmacro): Changed `args' and `num-args' to
- `%--args' and `%--num-args' in the hope of avoiding lexical
- vs. dynamic name clashes.
- (m-and): Use #f instead of '() where a condition fails.
-
- Plus big hierarchy reorganization, in which most of the previous
- occupants of lang/elisp moved to lang/elisp/primitives, with some
- internal processing being split out into lang/elisp/internals.
- The upshot looks like this:
-
- * internals/trace.scm, internals/set.scm, internals/load.scm,
- internals/fset.scm, internals/signal.scm, internals/time.scm,
- internals/format.scm, internals/null.scm,
- internals/evaluation.scm, primitives/buffers.scm,
- primitives/features.scm, primitives/format.scm,
- primitives/time.scm, primitives/guile.scm, primitives/keymaps.scm,
- primitives/lists.scm, primitives/load.scm, primitives/match.scm,
- primitives/numbers.scm, primitives/pure.scm, primitives/read.scm,
- primitives/signal.scm, primitives/strings.scm,
- primitives/symprop.scm, primitives/system.scm, primitives/fns.scm:
- New files.
-
- * features.scm, format.scm, fset.scm, guile.scm, keymaps.scm,
- lists.scm, load.scm, match.scm, numbers.scm, pure.scm, read.scm,
- signal.scm, strings.scm, symprop.scm, system.scm, time.scm,
- trace.scm: Removed files.
-
-2001-10-23 Neil Jerram <neil@ossau.uklinux.net>
-
- * match.scm (string-match): New implementation using new
- `make-emacs-regexp' primitive; old workaround implementation
- renamed to `string-match-workaround'.
-
-2001-10-21 Neil Jerram <neil@ossau.uklinux.net>
-
- * transform.scm (m-defun, m-defmacro, m-let, m-defvar,
- m-defconst): Use more selective tracing mechanism (provided by new
- file trace.scm).
-
- * symprop.scm (get, boundp), transform.scm (transform-lambda,
- m-defmacro): Remove unnecessary uses of nil-ify and t-ify.
-
- * match.scm (string-match): Workaround Guile/libc regex
- parenthesis bug.
-
- * emacs.scm: Move elisp primitive definitions into more specific
- files, so that emacs.scm contains only overall code.
-
- * Makefile.am: Added new files.
-
- * numbers.scm, trace.scm, time.scm, pure.scm, system.scm,
- read.scm, calling.scm, guile.scm: New files.
-
-2001-10-20 Neil Jerram <neil@ossau.uklinux.net>
-
- * Makefile.am (elisp_sources): Added match.scm and strings.scm.
-
- * match.scm, strings.scm: New files.
-
-2001-10-19 Neil Jerram <neil@ossau.uklinux.net>
-
- * transform.scm: Replace uses of `nil' by `#f' or `'()'.
-
- * Makefile.am (elisp_sources): Added lists.scm.
-
- * load.scm (the-elisp-module): Corrected (lang elisp emacs) module
- name.
-
- * lists.scm (lang): New file containing list-related primitives.
-
- * emacs.scm: Corrected module name.
-
-2001-10-19 Neil Jerram <neil@ossau.uklinux.net>
-
- Initial implementation of an Emacs Lisp translator, based on
- transformer code originally written by Mikael Djurfeldt.
-
- * Makefile.am, .cvsignore: New.
-
- * ChangeLog, README, buffers.scm, emacs.scm, features.scm,
- format.scm, fset.scm, keymaps.scm, load.scm, signal.scm,
- symprop.scm, transform.scm: New files.
-
-
+++ /dev/null
- -*- outline -*-
-
-This directory holds the Scheme side of a translator for Emacs Lisp.
-
-* Usage
-
-To load up the base Elisp environment:
-
- (use-modules (lang elisp base))
-
-Then you can switch into this module
-
- (define-module (lang elisp base))
-
-and start typing away in Elisp, or evaluate an individual Elisp
-expression from Scheme:
-
- (eval EXP (resolve-module '(lang elisp base)))
-
-A more convenient, higher-level interface is provided by (lang elisp
-interface):
-
- (use-modules (lang elisp interface))
-
-With this interface, you can evaluate an Elisp expression
-
- (eval-elisp EXP)
-
-load an Elisp file with no effect on the Scheme world
-
- (load-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el")
-
-load an Elisp file, automatically importing top level definitions into
-Scheme
-
- (use-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el")
-
-export Scheme objects to Elisp
-
- (export-to-elisp + - * my-func 'my-var)
-
-and try to bootstrap a complete Emacs environment:
-
- (load-emacs)
-
-* Status
-
-Please see the STATUS file for the full position.
-
-** Trying to load a complete Emacs environment.
-
-To try this, type `(use-modules (lang elisp interface))' and then
-`(load-emacs)'. The following output shows how far I get when I try
-this.
-
-guile> (use-modules (lang elisp interface))
-guile> (load-emacs)
-Calling loadup.el to clothe the bare Emacs...
-Loading /usr/share/emacs/20.7/lisp/loadup.el...
-Using load-path ("/usr/share/emacs/20.7/lisp/" "/usr/share/emacs/20.7/lisp/emacs-lisp/")
-Loading /usr/share/emacs/20.7/lisp/byte-run.el...
-Loading /usr/share/emacs/20.7/lisp/byte-run.el...done
-Loading /usr/share/emacs/20.7/lisp/subr.el...
-Loading /usr/share/emacs/20.7/lisp/subr.el...done
-Loading /usr/share/emacs/20.7/lisp/version.el...
-Loading /usr/share/emacs/20.7/lisp/version.el...done
-Loading /usr/share/emacs/20.7/lisp/map-ynp.el...
-Loading /usr/share/emacs/20.7/lisp/map-ynp.el...done
-Loading /usr/share/emacs/20.7/lisp/widget.el...
-Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...
-Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...done
-Loading /usr/share/emacs/20.7/lisp/widget.el...done
-Loading /usr/share/emacs/20.7/lisp/custom.el...
-Loading /usr/share/emacs/20.7/lisp/custom.el...done
-Loading /usr/share/emacs/20.7/lisp/cus-start.el...
-Note, built-in variable `abbrev-all-caps' not bound
- ... [many other variable not bound messages] ...
-Loading /usr/share/emacs/20.7/lisp/cus-start.el...done
-Loading /usr/share/emacs/20.7/lisp/international/mule.el...
-<unnamed port>: In procedure make-char-table in expression (@fop make-char-table (# #)):
-<unnamed port>: Symbol's function definition is void
-ABORT: (misc-error)
-
-Type "(backtrace)" to get more information or "(debug)" to enter the debugger.
-guile>
-
-That's 3279 lines ("wc -l") of Elisp code already, which isn't bad!
-
-I think that progress beyond this point basically means implementing
-multilingual and multibyte strings properly for Guile. Which is a
-_lot_ of work and requires IMO a very clear plan for Guile's role with
-respect to Emacs.
-
-* Design
-
-When thinking about how to implement an Elisp translator for Guile, it
-is important to realize that the great power of Emacs does not arise
-from Elisp (seen as a language in syntactic terms) alone, but from the
-combination of this language with the collection of primitives
-provided by the Emacs C source code. Therefore, to be of practical
-use, an Elisp translator needs to be more than just a transformer that
-translates sexps to Scheme expressions.
-
-The finished translator should consist of several parts...
-
-** Syntax transformation
-
-Although syntax transformation isn't all we need, we do still need it!
-
-This part is implemented by the (lang elisp transform) module; it is
-close to complete and seems to work pretty reliably.
-
-Note that transformed expressions use the `@fop' and `@bind' macros
-provided by...
-
-** C support for transformed expressions
-
-For performance and historical reasons (and perhaps necessity - I
-haven't thought about it enough yet), some of the transformation
-support is written in C.
-
-*** @fop
-
-The `@fop' macro is used to dispatch Elisp applications. Its first
-argument is a symbol, and this symbol's function slot is examined to
-find a procedure or macro to apply to the remaining arguments. `@fop'
-also handles aliasing (`defalias'): in this case the function slot
-contains another symbol.
-
-Once `@fop' has found the appropriate procedure or macro to apply, it
-returns an application expression in which that procedure or macro
-replaces the `@fop' and the original symbol. Hence no Elisp-specific
-evaluator support is required to perform the application.
-
-*** @bind
-
-Currently, Elisp variables are the same as Scheme variables, so
-variable references are effectively untransformed.
-
-The `@bind' macro does Elisp-style dynamic variable binding.
-Basically, it locates the named top level variables, `set!'s them to
-new values, evaluates its body, and then uses `set!' again to restore
-the original values.
-
-Because of the body evaluation, `@bind' requires evaluator support.
-In fact, the `@bind' macro code does little more than replace itself
-with the memoized SCM_IM_BIND. Most of the work is done by the
-evaluator when it hits SCM_IM_BIND.
-
-One theoretical problem with `@bind' is that any local Scheme variable
-in the same scope and with the same name as an Elisp variable will
-shadow the Elisp variable. But in practice it's difficult to set up
-such a situation; an exception is the translator code itself, so there
-we mangle the relevant Scheme variable names a bit to avoid the
-problem.
-
-Other possible problems with this approach are that it might not be
-possible to implement buffer local variables properly, and that
-`@bind' might become too inefficient when we implement full support
-for undefining Scheme variables. So we might in future have to
-transform Elisp variable references after all.
-
-*** Truth value stuff
-
-Following extensive discussions on the Guile mailing list between
-September 2001 and January 2002, we decided to go with Jim Blandy's
-proposal. See devel/translation/lisp-and-scheme.text for details.
-
-- The Elisp nil value is a new immediate SCM_MAKIFLAG, eq?-distinct
-from both #f and '() (and of course any other Scheme value). It can
-be accessed via the (guile) binding `%nil', and prints as `#nil'.
-
-- All Elisp primitives treat #nil, #f and '() as identical.
-
-- Scheme truth-testing primitives have been modified so that they
-treat #nil the same as #f.
-
-- Scheme list-manipulating primitives have been modified so that they
-treat #nil the same as '().
-
-- The Elisp t value is the same as #t.
-
-** Emacs editing primitives
-
-Buffers, keymaps, text properties, windows, frames etc. etc.
-
-Basically, everything that is implemented as a primitive in the Emacs
-C code needs to be implemented either in Scheme or in C for Guile.
-
-The Scheme files in the primitives subdirectory implement some of
-these primitives in Scheme. Not because that is the right decision,
-but because this is a proof of concept and it's quicker to write badly
-performing code in Scheme.
-
-Ultimately, most of these primitive definitions should really come
-from the Emacs C code itself, translated or preprocessed in a way that
-makes it compile with Guile. I think this is pretty close to the work
-that Ken Raeburn has been doing on the Emacs codebase.
-
-** Reading and printing support
-
-Elisp is close enough to Scheme that it's convenient to coopt the
-existing Guile reader rather than to write a new one from scratch, but
-there are a few syntactic differences that will require changes in
-reading and printing. None of the following changes has yet been
-implemented.
-
-- Character syntax is `?a' rather than `#\a'. (Not done. More
- precisely, `?a' in Elisp isn't character syntax but an alternative
- integer syntax. Note that we could support most of the `?a' syntax
- simply by doing
-
- (define ?a (char->integer #\a)
- (define ?b (char->integer #\b)
-
- and so on.)
-
-- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'.
-
-- When in an Elisp environment, #nil and #t should print as `nil' and
- `t'.
-
-** The Elisp evaluation module (lang elisp base)
-
-Fundamentally, Guile's module system can't be used to package Elisp
-code in the same way it is used for Scheme code, because Elisp
-function definitions are stored as symbol properties (in the symbol's
-"function slot") and so are global. On the other hand, it is useful
-(necessary?) to associate some particular module with Elisp evaluation
-because
-
-- Elisp variables are currently implemented as Scheme variables and so
- need to live in some module
-
-- a syntax transformer is a property of a module.
-
-Therefore we have the (lang elisp base) module, which acts as the
-repository for all Elisp variables and the site of all Elisp
-evaluation.
-
-The initial environment provided by this module is intended to be a
-non-Emacs-dependent subset of Elisp. To get the idea, imagine someone
-who wants to write an extension function for, say Gnucash, and simply
-prefers to write in Elisp rather than in Scheme. He/she therefore
-doesn't buffers, keymaps and so on, just the basic language syntax and
-core data functions like +, *, concat, length etc., plus specific
-functions made available by Gnucash.
-
-(lang elisp base) achieves this by
-
-- importing Scheme definitions for some Emacs primitives from the
- files in the primitives subdirectory
-
-- then switching into Elisp syntax.
-
-After this point, `(eval XXX (resolve-module '(lang elisp base)))'
-will evaluate XXX as an Elisp expression in the (lang elisp base)
-module. (`eval-elisp' in (lang elisp interface) is a more convenient
-wrapper for this.)
-
-** Full Emacs environment
-
-The difference between the initial (lang elisp base) environment and a
-fully loaded Emacs equivalent is
-
-- more primitives: buffers, char-tables and many others
-
-- the bootstrap Elisp code that an undumped Emacs loads during
- installation by calling `(load "loadup.el")'.
-
-We don't have all the missing primitives, but we can already get
-through some of loadup.el. The Elisp function `load-emacs' (defined
-in (lang elisp base) initiates the loading of loadup.el; (lang elisp
-interface) exports `load-emacs' to Scheme.
-
-`load-emacs' loads so much Elisp code that it's an excellent way to
-test the translator. In current practice, it runs for a while and
-then fails when it gets to an undefined primitive or a bug in the
-translator. Eventually, it should go all the way. (And then we can
-worry about adding unexec support to Guile!) For the output that
-currently results from calling `(load-emacs)', see above in the Status
-section.
-
-* Resources
-
-** Ken Raeburn's Guile Emacs page
-
-http://www.mit.edu/~raeburn/guilemacs/
-
-** Keisuke Nishida's Gemacs project
-
-http://gemacs.sourceforge.net
-
-** Jim Blandy's nil/#f/() notes
-
-http://sanpietro.red-bean.com/guile/guile/old/3114.html
-
-Also now stored as guile-core/devel/translation/lisp-and-scheme.text
-in Guile CVS.
-
-** Mikael Djurfeldt's notes on translation
-
-See file guile-core/devel/translation/langtools.text in Guile CVS.
+++ /dev/null
- -*-text-*-
-
-I've now finished my currently planned work on the Emacs Lisp
-translator in guile-core CVS.
-
-It works well enough for experimentation and playing around with --
-see the README file for details of what it _can_ do -- but has two
-serious restrictions:
-
-- Most Emacs Lisp primitives are not yet implemented. In particular,
- there are no buffer-related primitives.
-
-- Performance compares badly with Emacs. Using a handful of
- completely unscientific tests, I found that Guile was between 2 and
- 20 times slower than Emacs. (See the comment in
- lang/elisp/example.el for details of tests and results.)
-
-Interestingly, both these restrictions point in the same direction:
-the way forward is to define the primitives by compiling a
-preprocessed version of the Emacs source code, not by trying to
-implement them in Scheme. (Which, of course, is what Ken Raeburn's
-project is already trying to do.)
-
-Given this conclusion, I expect that most of the translator's Scheme
-code will eventually become obsolete, replaced by bits of Emacs C
-code. Until then, though, it should have a role:
-
-- as a guide to the Guile Emacs project on how to interface to the
- Elisp support in libguile (notably, usage of `@fop' and `@bind')
-
-- as a proof of concept and fun thing to experiment with
-
-- as a working translator that could help us develop our picture of
- how we want to integrate translator usage in general with the rest
- of Guile.
+++ /dev/null
-(define-module (lang elisp base)
-
- ;; Be pure. Nothing in this module requires symbols that map to the
- ;; standard Guile builtins, and it creates a problem if this module
- ;; has access to them, as @bind can dynamically change their values.
- ;; Transformer output always uses the values of builtin procedures
- ;; and macros directly.
- #:pure
-
- ;; {Elisp Primitives}
- ;;
- ;; In other words, Scheme definitions of elisp primitives. This
- ;; should (ultimately) include everything that Emacs defines in C.
- #:use-module (lang elisp primitives buffers)
- #:use-module (lang elisp primitives char-table)
- #:use-module (lang elisp primitives features)
- #:use-module (lang elisp primitives format)
- #:use-module (lang elisp primitives fns)
- #:use-module (lang elisp primitives guile)
- #:use-module (lang elisp primitives keymaps)
- #:use-module (lang elisp primitives lists)
- #:use-module (lang elisp primitives load)
- #:use-module (lang elisp primitives match)
- #:use-module (lang elisp primitives numbers)
- #:use-module (lang elisp primitives pure)
- #:use-module (lang elisp primitives read)
- #:use-module (lang elisp primitives signal)
- #:use-module (lang elisp primitives strings)
- #:use-module (lang elisp primitives symprop)
- #:use-module (lang elisp primitives syntax)
- #:use-module (lang elisp primitives system)
- #:use-module (lang elisp primitives time)
-
- ;; Now switch into Emacs Lisp syntax.
- #:use-syntax (lang elisp transform))
-
-;;; Everything below here is written in Elisp.
-
-(defun load-emacs (&optional new-load-path debug)
- (if debug (message "load-path: %s" load-path))
- (cond (new-load-path
- (message "Setting load-path to: %s" new-load-path)
- (setq load-path new-load-path)))
- (if debug (message "load-path: %s" load-path))
- (scheme (read-set! keywords 'prefix))
- (message "Calling loadup.el to clothe the bare Emacs...")
- (load "loadup.el")
- (message "Guile Emacs now fully clothed"))
+++ /dev/null
-
-(defun html-page (title &rest contents)
- (concat "<HTML>\n"
- "<HEAD>\n"
- "<TITLE>" title "</TITLE>\n"
- "</HEAD>\n"
- "<BODY>\n"
- (apply 'concat contents)
- "</BODY>\n"
- "</HTML>\n"))
-
-(defmacro time (repeat-count &rest body)
- `(let ((count ,repeat-count)
- (beg (current-time))
- end)
- (while (> count 0)
- (setq count (- count 1))
- ,@body)
- (setq end (current-time))
- (+ (* 1000000.0 (+ (* 65536.0 (- (car end) (car beg)))
- (- (cadr end) (cadr beg))))
- (* 1.0 (- (caddr end) (caddr beg))))))
-
-;Non-scientific performance measurements (Guile measurements are with
-;`guile -q --no-debug'):
-;
-;(time 100000 (+ 3 4))
-; => 225,071 (Emacs) 4,000,000 (Guile)
-;(time 100000 (lambda () 1))
-; => 2,410,456 (Emacs) 4,000,000 (Guile)
-;(time 100000 (apply 'concat (mapcar (lambda (s) (concat s "." s)) '("a" "b" "c" "d"))))
-; => 10,185,792 (Emacs) 136,000,000 (Guile)
-;(defun sc (s) (concat s "." s))
-;(time 100000 (apply 'concat (mapcar 'sc '("a" "b" "c" "d"))))
-; => 7,870,055 (Emacs) 26,700,000 (Guile)
-;
-;Sadly, it looks like the translator's performance sucks quite badly
-;when compared with Emacs. But the translator is still very new, so
-;there's probably plenty of room of improvement.
+++ /dev/null
-(define-module (lang elisp expand)
- #:export (expand))
-
-(define (expand x) x)
+++ /dev/null
-(define-module (lang elisp interface)
- #:use-syntax (lang elisp expand)
- #:use-module (lang elisp internals evaluation)
- #:use-module (lang elisp internals fset)
- #:use-module ((lang elisp internals load) #:select ((load . elisp:load)))
- #:use-module ((lang elisp transform) #:select (transformer))
- #:export (eval-elisp
- translate-elisp
- elisp-function
- elisp-variable
- load-elisp-file
- load-elisp-library
- use-elisp-file
- use-elisp-library
- export-to-elisp
- load-emacs))
-
-;;; This file holds my ideas for the mechanisms that would be useful
-;;; to exchange definitions between Scheme and Elisp.
-
-(define (eval-elisp x)
- "Evaluate the Elisp expression @var{x}."
- (save-module-excursion
- (lambda ()
- (set-current-module the-elisp-module)
- (primitive-eval x))))
-
-(define (translate-elisp x)
- "Translate the Elisp expression @var{x} to equivalent Scheme code."
- (transformer x))
-
-(define (elisp-function sym)
- "Return the procedure or macro that implements @var{sym} in Elisp.
-If @var{sym} has no Elisp function definition, return @code{#f}."
- (fref sym))
-
-(define (elisp-variable sym)
- "Return the variable that implements @var{sym} in Elisp.
-If @var{sym} has no Elisp variable definition, return @code{#f}."
- (module-variable the-elisp-module sym))
-
-(define (load-elisp-file file-name)
- "Load @var{file-name} into the Elisp environment.
-@var{file-name} is assumed to name a file containing Elisp code."
- ;; This is the same as Elisp's `load-file', so use that if it is
- ;; available, otherwise duplicate the definition of `load-file' from
- ;; files.el.
- (let ((load-file (elisp-function 'load-file)))
- (if load-file
- (load-file file-name)
- (elisp:load file-name #f #f #t))))
-
-(define (load-elisp-library library)
- "Load library @var{library} into the Elisp environment.
-@var{library} should name an Elisp code library that can be found in
-one of the directories of @code{load-path}."
- ;; This is the same as Elisp's `load-file', so use that if it is
- ;; available, otherwise duplicate the definition of `load-file' from
- ;; files.el.
- (let ((load-library (elisp-function 'load-library)))
- (if load-library
- (load-library library)
- (elisp:load library))))
-
-(define export-module-name
- (let ((counter 0))
- (lambda ()
- (set! counter (+ counter 1))
- (list 'lang 'elisp
- (string->symbol (string-append "imports:"
- (number->string counter)))))))
-
-(define use-elisp-file
- (procedure->memoizing-macro
- (lambda (exp env)
- "Load Elisp code file @var{file-name} and import its definitions
-into the current Scheme module. If any @var{imports} are specified,
-they are interpreted as selection and renaming specifiers as per
-@code{use-modules}."
- (let ((file-name (cadr exp))
- (env (cddr exp)))
- (let ((export-module-name (export-module-name)))
- `(begin
- (fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
- (beautify-user-module! (resolve-module ',export-module-name))
- (load-elisp-file ,file-name)
- (use-modules (,export-module-name ,@imports))
- (fluid-set! ,elisp-export-module #f)))))))
-
-(define use-elisp-library
- (procedure->memoizing-macro
- (lambda (exp env)
- "Load Elisp library @var{library} and import its definitions into
-the current Scheme module. If any @var{imports} are specified, they
-are interpreted as selection and renaming specifiers as per
-@code{use-modules}."
- (let ((library (cadr exp))
- (env (cddr exp)))
- (let ((export-module-name (export-module-name)))
- `(begin
- (fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
- (beautify-user-module! (resolve-module ',export-module-name))
- (load-elisp-library ,library)
- (use-modules (,export-module-name ,@imports))
- (fluid-set! ,elisp-export-module #f)))))))
-
-(define (export-to-elisp . defs)
- "Export procedures and variables specified by @var{defs} to Elisp.
-Each @var{def} is either an object, in which case that object must be
-a named procedure or macro and is exported to Elisp under its Scheme
-name; or a symbol, in which case the variable named by that symbol is
-exported under its Scheme name; or a pair @var{(obj . name)}, in which
-case @var{obj} must be a procedure, macro or symbol as already
-described and @var{name} specifies the name under which that object is
-exported to Elisp."
- (for-each (lambda (def)
- (let ((obj (if (pair? def) (car def) def))
- (name (if (pair? def) (cdr def) #f)))
- (cond ((procedure? obj)
- (or name
- (set! name (procedure-name obj)))
- (if name
- (fset name obj)
- (error "No procedure name specified or deducible:" obj)))
- ((macro? obj)
- (or name
- (set! name (macro-name obj)))
- (if name
- (fset name obj)
- (error "No macro name specified or deducible:" obj)))
- ((symbol? obj)
- (or name
- (set! name obj))
- (module-add! the-elisp-module name
- (module-ref (current-module) obj)))
- (else
- (error "Can't export this kind of object to Elisp:" obj)))))
- defs))
-
-(define load-emacs (elisp-function 'load-emacs))
+++ /dev/null
-(define-module (lang elisp internals evaluation)
- #:export (the-elisp-module))
-
-;;;; {Elisp Evaluation}
-
-;;;; All elisp evaluation happens within the same module - namely
-;;;; (lang elisp base). This is necessary both because elisp itself
-;;;; has no concept of different modules - reflected for example in
-;;;; its single argument `eval' function - and because Guile's current
-;;;; implementation of elisp stores elisp function definitions in
-;;;; slots in global symbol objects.
-
-(define the-elisp-module (resolve-module '(lang elisp base)))
+++ /dev/null
-(define-module (lang elisp internals format)
- #:pure
- #:use-module (ice-9 r5rs)
- #:use-module ((ice-9 format) #:select ((format . scheme:format)))
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals signal)
- #:replace (format)
- #:export (message))
-
-(define (format control-string . args)
-
- (define (cons-string str ls)
- (let loop ((sl (string->list str))
- (ls ls))
- (if (null? sl)
- ls
- (loop (cdr sl) (cons (car sl) ls)))))
-
- (let loop ((input (string->list control-string))
- (args args)
- (output '())
- (mid-control #f))
- (if (null? input)
- (if mid-control
- (error "Format string ends in middle of format specifier")
- (list->string (reverse output)))
- (if mid-control
- (case (car input)
- ((#\%)
- (loop (cdr input)
- args
- (cons #\% output)
- #f))
- (else
- (loop (cdr input)
- (cdr args)
- (cons-string (case (car input)
- ((#\s) (scheme:format #f "~A" (car args)))
- ((#\d) (number->string (car args)))
- ((#\o) (number->string (car args) 8))
- ((#\x) (number->string (car args) 16))
- ((#\e) (number->string (car args))) ;FIXME
- ((#\f) (number->string (car args))) ;FIXME
- ((#\g) (number->string (car args))) ;FIXME
- ((#\c) (let ((a (car args)))
- (if (char? a)
- (string a)
- (string (integer->char a)))))
- ((#\S) (scheme:format #f "~S" (car args)))
- (else
- (error "Invalid format operation %%%c" (car input))))
- output)
- #f)))
- (case (car input)
- ((#\%)
- (loop (cdr input) args output #t))
- (else
- (loop (cdr input) args (cons (car input) output) #f)))))))
-
-(define (message control-string . args)
- (display (apply format control-string args))
- (newline))
+++ /dev/null
-(define-module (lang elisp internals fset)
- #:use-module (lang elisp internals evaluation)
- #:use-module (lang elisp internals lambda)
- #:use-module (lang elisp internals signal)
- #:export (fset
- fref
- fref/error-if-void
- elisp-apply
- interactive-specification
- not-subr?
- elisp-export-module))
-
-(define the-variables-module (resolve-module '(lang elisp variables)))
-
-;; By default, Guile GC's unreachable symbols. So we need to make
-;; sure they stay reachable!
-(define syms '())
-
-;; elisp-export-module, if non-#f, holds a module to which definitions
-;; should be exported under their normal symbol names. This is used
-;; when importing Elisp definitions into Scheme.
-(define elisp-export-module (make-fluid))
-
-;; Store the procedure, macro or alias symbol PROC in SYM's function
-;; slot.
-(define (fset sym proc)
- (or (memq sym syms)
- (set! syms (cons sym syms)))
- (let ((vcell (symbol-fref sym))
- (vsym #f)
- (export-module (fluid-ref elisp-export-module)))
- ;; Playing around with variables and name properties... For the
- ;; reasoning behind this, see the commentary in (lang elisp
- ;; variables).
- (cond ((procedure? proc)
- ;; A procedure created from Elisp will already have a name
- ;; property attached, with value of the form
- ;; <elisp-defun:NAME> or <elisp-lambda>. Any other
- ;; procedure coming through here must be an Elisp primitive
- ;; definition, so we give it a name of the form
- ;; <elisp-subr:NAME>.
- (or (procedure-name proc)
- (set-procedure-property! proc
- 'name
- (symbol-append '<elisp-subr: sym '>)))
- (set! vsym (procedure-name proc)))
- ((macro? proc)
- ;; Macros coming through here must be defmacros, as all
- ;; primitive special forms are handled directly by the
- ;; transformer.
- (set-procedure-property! (macro-transformer proc)
- 'name
- (symbol-append '<elisp-defmacro: sym '>))
- (set! vsym (procedure-name (macro-transformer proc))))
- (else
- ;; An alias symbol.
- (set! vsym (symbol-append '<elisp-defalias: sym '>))))
- ;; This is the important bit!
- (if (variable? vcell)
- (variable-set! vcell proc)
- (begin
- (set! vcell (make-variable proc))
- (symbol-fset! sym vcell)
- ;; Playing with names and variables again - see above.
- (module-add! the-variables-module vsym vcell)
- (module-export! the-variables-module (list vsym))))
- ;; Export variable to the export module, if non-#f.
- (if (and export-module
- (or (procedure? proc)
- (macro? proc)))
- (begin
- (module-add! export-module sym vcell)
- (module-export! export-module (list sym))))))
-
-;; Retrieve the procedure or macro stored in SYM's function slot.
-;; Note the asymmetry w.r.t. fset: if fref finds an alias symbol, it
-;; recursively calls fref on that symbol. Returns #f if SYM's
-;; function slot doesn't contain a valid definition.
-(define (fref sym)
- (let ((var (symbol-fref sym)))
- (if (and var (variable? var))
- (let ((proc (variable-ref var)))
- (cond ((symbol? proc)
- (fref proc))
- (else
- proc)))
- #f)))
-
-;; Same as fref, but signals an Elisp error if SYM's function
-;; definition is void.
-(define (fref/error-if-void sym)
- (or (fref sym)
- (signal 'void-function (list sym))))
-
-;; Maps a procedure to its (interactive ...) spec.
-(define interactive-specification (make-object-property))
-
-;; Maps a procedure to #t if it is NOT a built-in.
-(define not-subr? (make-object-property))
-
-(define (elisp-apply function . args)
- (apply apply
- (cond ((symbol? function)
- (fref/error-if-void function))
- ((procedure? function)
- function)
- ((and (pair? function)
- (eq? (car function) 'lambda))
- (eval (transform-lambda/interactive function '<elisp-lambda>)
- the-root-module))
- (else
- (signal 'invalid-function (list function))))
- args))
+++ /dev/null
-(define-module (lang elisp internals lambda)
- #:use-syntax (lang elisp expand)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp transform)
- #:export (parse-formals
- transform-lambda/interactive
- interactive-spec))
-
-;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
-;;; returns three values: (i) list of symbols for required arguments,
-;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
-;;; #f if there is no rest argument.
-(define (parse-formals formals)
- (letrec ((do-required
- (lambda (required formals)
- (if (null? formals)
- (values (reverse required) '() #f)
- (let ((next-sym (car formals)))
- (cond ((not (symbol? next-sym))
- (error "Bad formals (non-symbol in required list)"))
- ((eq? next-sym '&optional)
- (do-optional required '() (cdr formals)))
- ((eq? next-sym '&rest)
- (do-rest required '() (cdr formals)))
- (else
- (do-required (cons next-sym required)
- (cdr formals))))))))
- (do-optional
- (lambda (required optional formals)
- (if (null? formals)
- (values (reverse required) (reverse optional) #f)
- (let ((next-sym (car formals)))
- (cond ((not (symbol? next-sym))
- (error "Bad formals (non-symbol in optional list)"))
- ((eq? next-sym '&rest)
- (do-rest required optional (cdr formals)))
- (else
- (do-optional required
- (cons next-sym optional)
- (cdr formals))))))))
- (do-rest
- (lambda (required optional formals)
- (if (= (length formals) 1)
- (let ((next-sym (car formals)))
- (if (symbol? next-sym)
- (values (reverse required) (reverse optional) next-sym)
- (error "Bad formals (non-symbol rest formal)")))
- (error "Bad formals (more than one rest formal)")))))
-
- (do-required '() (cond ((list? formals)
- formals)
- ((symbol? formals)
- (list '&rest formals))
- (else
- (error "Bad formals (not a list or a single symbol)"))))))
-
-(define (transform-lambda exp)
- (call-with-values (lambda () (parse-formals (cadr exp)))
- (lambda (required optional rest)
- (let ((num-required (length required))
- (num-optional (length optional)))
- `(,lambda %--args
- (,let ((%--num-args (,length %--args)))
- (,cond ((,< %--num-args ,num-required)
- (,error "Wrong number of args (not enough required args)"))
- ,@(if rest
- '()
- `(((,> %--num-args ,(+ num-required num-optional))
- (,error "Wrong number of args (too many args)"))))
- (else
- (, @bind ,(append (map (lambda (i)
- (list (list-ref required i)
- `(,list-ref %--args ,i)))
- (iota num-required))
- (map (lambda (i)
- (let ((i+nr (+ i num-required)))
- (list (list-ref optional i)
- `(,if (,> %--num-args ,i+nr)
- (,list-ref %--args ,i+nr)
- ,%nil))))
- (iota num-optional))
- (if rest
- (list (list rest
- `(,if (,> %--num-args
- ,(+ num-required
- num-optional))
- (,list-tail %--args
- ,(+ num-required
- num-optional))
- ,%nil)))
- '()))
- ,@(map transformer (cddr exp)))))))))))
-
-(define (set-not-subr! proc boolean)
- (set! (not-subr? proc) boolean))
-
-(define (transform-lambda/interactive exp name)
- (fluid-set! interactive-spec #f)
- (let* ((x (transform-lambda exp))
- (is (fluid-ref interactive-spec)))
- `(,let ((%--lambda ,x))
- (,set-procedure-property! %--lambda (,quote name) (,quote ,name))
- (,set-not-subr! %--lambda #t)
- ,@(if is
- `((,set! (,interactive-specification %--lambda) (,quote ,is)))
- '())
- %--lambda)))
-
-(define interactive-spec (make-fluid))
+++ /dev/null
-(define-module (lang elisp internals load)
- #:use-module (ice-9 optargs)
- #:use-module (lang elisp internals signal)
- #:use-module (lang elisp internals format)
- #:use-module (lang elisp internals evaluation)
- #:replace (load)
- #:export (load-path))
-
-(define load-path '("/usr/share/emacs/20.7/lisp/"
- "/usr/share/emacs/20.7/lisp/emacs-lisp/"))
-
-(define* (load file #:optional noerror nomessage nosuffix must-suffix)
- (define (load1 filename)
- (let ((pathname (let loop ((dirs (if (char=? (string-ref filename 0) #\/)
- '("")
- load-path)))
- (cond ((null? dirs) #f)
- ((file-exists? (in-vicinity (car dirs) filename))
- (in-vicinity (car dirs) filename))
- (else (loop (cdr dirs)))))))
- (if pathname
- (begin
- (or nomessage
- (message "Loading %s..." pathname))
- (with-input-from-file pathname
- (lambda ()
- (let loop ((form (read)))
- (or (eof-object? form)
- (begin
- ;; Note that `eval' already incorporates use
- ;; of the specified module's transformer.
- (eval form the-elisp-module)
- (loop (read)))))))
- (or nomessage
- (message "Loading %s...done" pathname))
- #t)
- #f)))
- (or (and (not nosuffix)
- (load1 (string-append file ".el")))
- (and (not must-suffix)
- (load1 file))
- noerror
- (signal 'file-error
- (list "Cannot open load file" file))))
+++ /dev/null
-(define-module (lang elisp internals null)
- #:export (->nil lambda->nil null))
-
-(define (->nil x)
- (or x %nil))
-
-(define (lambda->nil proc)
- (lambda args
- (->nil (apply proc args))))
-
-(define (null obj)
- (->nil (or (not obj)
- (null? obj))))
+++ /dev/null
-(define-module (lang elisp internals set)
- #:use-module (lang elisp internals evaluation)
- #:use-module (lang elisp internals signal)
- #:export (set value))
-
-;; Set SYM's variable value to VAL, and return VAL.
-(define (set sym val)
- (if (module-defined? the-elisp-module sym)
- (module-set! the-elisp-module sym val)
- (module-define! the-elisp-module sym val))
- val)
-
-;; Return SYM's variable value. If it has none, signal an error if
-;; MUST-EXIST is true, just return #nil otherwise.
-(define (value sym must-exist)
- (if (module-defined? the-elisp-module sym)
- (module-ref the-elisp-module sym)
- (if must-exist
- (error "Symbol's value as variable is void:" sym)
- %nil)))
+++ /dev/null
-(define-module (lang elisp internals signal)
- #:use-module (lang elisp internals format)
- #:replace (error)
- #:export (signal
- wta))
-
-(define (signal error-symbol data)
- (scm-error 'elisp-signal
- #f
- "Signalling ~A with data ~S"
- (list error-symbol data)
- #f))
-
-(define (error . args)
- (signal 'error (list (apply format args))))
-
-(define (wta expected actual pos)
- (signal 'wrong-type-argument (list expected actual)))
+++ /dev/null
-(define-module (lang elisp internals time)
- #:use-module (ice-9 optargs)
- #:export (format-time-string))
-
-(define* (format-time-string format-string #:optional time universal)
- (strftime format-string
- ((if universal gmtime localtime)
- (if time
- (+ (ash (car time) 16)
- (let ((time-cdr (cdr time)))
- (if (pair? time-cdr)
- (car time-cdr)
- time-cdr)))
- (current-time)))))
+++ /dev/null
-(define-module (lang elisp internals trace)
- #:export (trc trc-syms trc-all trc-none))
-
-(define *syms* #f)
-
-(define (trc-syms . syms)
- (set! *syms* syms))
-
-(define (trc-all)
- (set! *syms* #f))
-
-(define (trc-none)
- (set! *syms* '()))
-
-(define (trc . args)
- (let ((sym (car args))
- (args (cdr args)))
- (if (or (and *syms*
- (memq sym *syms*))
- (not *syms*))
- (begin
- (write sym)
- (display ": ")
- (write args)
- (newline)))))
-
-;; Default to no tracing.
-(trc-none)
+++ /dev/null
-(define-module (lang elisp primitives buffers)
- #:use-module (ice-9 optargs)
- #:use-module (lang elisp internals fset))
-
-(fset 'buffer-disable-undo
- (lambda* (#:optional buffer)
- 'unimplemented))
-
-(fset 're-search-forward
- (lambda* (regexp #:optional bound noerror count)
- 'unimplemented))
-
-(fset 're-search-backward
- (lambda* (regexp #:optional bound noerror count)
- 'unimplemented))
-
+++ /dev/null
-(define-module (lang elisp primitives char-table)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals null)
- #:use-module (ice-9 optargs))
-
-(fset 'make-char-table
- (lambda* (purpose #:optional init)
- "Return a newly created char-table, with purpose PURPOSE.
-Each element is initialized to INIT, which defaults to nil.
-PURPOSE should be a symbol which has a `char-table-extra-slots' property.
-The property's value should be an integer between 0 and 10."
- (list purpose (vector init))))
-
-(fset 'define-charset
- (lambda (charset-id charset-symbol info-vector)
- (list 'charset charset-id charset-symbol info-vector)))
-
-(fset 'setup-special-charsets
- (lambda ()
- 'unimplemented))
-
-(fset 'make-char-internal
- (lambda ()
- 'unimplemented))
+++ /dev/null
-(define-module (lang elisp primitives features)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals load)
- #:use-module (lang elisp internals null)
- #:use-module (ice-9 optargs))
-
-(define-public features '())
-
-(fset 'provide
- (lambda (feature)
- (or (memq feature features)
- (set! features (cons feature features)))))
-
-(fset 'featurep
- (lambda (feature)
- (->nil (memq feature features))))
-
-(fset 'require
- (lambda* (feature #:optional file-name noerror)
- (or (memq feature features)
- (load (or file-name
- (symbol->string feature))
- noerror
- #f
- #f
- #t))))
+++ /dev/null
-(define-module (lang elisp primitives fns)
- #:use-module (lang elisp internals set)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals null))
-
-(fset 'fset fset)
-(fset 'defalias fset)
-
-(fset 'apply elisp-apply)
-
-(fset 'funcall
- (lambda (function . args)
- (elisp-apply function args)))
-
-(fset 'interactive-p
- (lambda ()
- %nil))
-
-(fset 'commandp
- (lambda (sym)
- (if (interactive-specification (fref sym)) #t %nil)))
-
-(fset 'fboundp
- (lambda (sym)
- (->nil (variable? (symbol-fref sym)))))
-
-(fset 'symbol-function fref/error-if-void)
-
-;; FIXME -- lost in the syncase conversion
-;; (fset 'macroexpand macroexpand)
-
-(fset 'subrp
- (lambda (obj)
- (->nil (not (not-subr? obj)))))
-
-(fset 'byte-code-function-p
- (lambda (object)
- %nil))
-
-(fset 'run-hooks
- (lambda hooks
- (for-each (lambda (hooksym)
- (for-each (lambda (fn)
- (elisp-apply fn '()))
- (value hooksym #f)))
- hooks)))
+++ /dev/null
-(define-module (lang elisp primitives format)
- #:use-module (lang elisp internals format)
- #:use-module (lang elisp internals fset))
-
-(fset 'format format)
-(fset 'message message)
+++ /dev/null
-(define-module (lang elisp primitives guile)
- #:use-module (lang elisp internals fset))
-
-;;; {Importing Guile procedures into Elisp}
-
-;; It may be worthwhile to import some Guile procedures into the Elisp
-;; environment. For now, though, we don't do this.
-
-(if #f
- (let ((accessible-procedures
- (apropos-fold (lambda (module name var data)
- (cons (cons name var) data))
- '()
- ""
- (apropos-fold-accessible (current-module)))))
- (for-each (lambda (name var)
- (if (procedure? var)
- (fset name var)))
- (map car accessible-procedures)
- (map cdr accessible-procedures))))
+++ /dev/null
-(define-module (lang elisp primitives keymaps)
- #:use-module (lang elisp internals fset))
-
-(define (make-sparse-keymap)
- (list 'keymap))
-
-(define (define-key keymap key def)
- (set-cdr! keymap
- (cons (cons key def) (cdr keymap))))
-
-(define global-map (make-sparse-keymap))
-(define esc-map (make-sparse-keymap))
-(define ctl-x-map (make-sparse-keymap))
-(define ctl-x-4-map (make-sparse-keymap))
-(define ctl-x-5-map (make-sparse-keymap))
-
-;;; {Elisp Exports}
-
-(fset 'make-sparse-keymap make-sparse-keymap)
-(fset 'define-key define-key)
-
-(export global-map
- esc-map
- ctl-x-map
- ctl-x-4-map
- ctl-x-5-map)
+++ /dev/null
-(define-module (lang elisp primitives lists)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals null)
- #:use-module (lang elisp internals signal))
-
-(fset 'cons cons)
-
-(fset 'null null)
-
-(fset 'not null)
-
-(fset 'car
- (lambda (l)
- (if (null l)
- %nil
- (car l))))
-
-(fset 'cdr
- (lambda (l)
- (if (null l)
- %nil
- (cdr l))))
-
-(fset 'eq
- (lambda (x y)
- (or (eq? x y)
- (and (null x) (null y)))))
-
-(fset 'equal
- (lambda (x y)
- (or (equal? x y)
- (and (null x) (null y)))))
-
-(fset 'setcar set-car!)
-
-(fset 'setcdr set-cdr!)
-
-(for-each (lambda (sym proc)
- (fset sym
- (lambda (elt list)
- (if (null list)
- %nil
- (if (null elt)
- (let loop ((l list))
- (cond ((null l) %nil)
- ((null (car l)) l)
- (else (loop (cdr l)))))
- (proc elt list))))))
- '( memq member assq assoc)
- `(,memq ,member ,assq ,assoc))
-
-(fset 'length
- (lambda (x)
- (cond ((null x) 0)
- ((pair? x) (length x))
- ((vector? x) (vector-length x))
- ((string? x) (string-length x))
- (else (wta 'sequencep x 1)))))
-
-(fset 'copy-sequence
- (lambda (x)
- (cond ((list? x) (list-copy x))
- ((vector? x) (error "Vector copy not yet implemented"))
- ((string? x) (string-copy x))
- (else (wta 'sequencep x 1)))))
-
-(fset 'elt
- (lambda (obj i)
- (cond ((pair? obj) (list-ref obj i))
- ((vector? obj) (vector-ref obj i))
- ((string? obj) (char->integer (string-ref obj i))))))
-
-(fset 'list list)
-
-(fset 'mapcar
- (lambda (function sequence)
- (map (lambda (elt)
- (elisp-apply function (list elt)))
- (cond ((null sequence) '())
- ((list? sequence) sequence)
- ((vector? sequence) (vector->list sequence))
- ((string? sequence) (map char->integer (string->list sequence)))
- (else (wta 'sequencep sequence 2))))))
-
-(fset 'nth
- (lambda (n list)
- (if (or (null list)
- (>= n (length list)))
- %nil
- (list-ref list n))))
-
-(fset 'listp
- (lambda (object)
- (or (null object)
- (list? object))))
-
-(fset 'consp pair?)
-
-(fset 'nconc
- (lambda args
- (apply append! (map (lambda (arg)
- (if arg arg '()))
- args))))
+++ /dev/null
-(define-module (lang elisp primitives load)
- #:use-module (lang elisp internals load)
- #:use-module (lang elisp internals evaluation)
- #:use-module (lang elisp internals fset))
-
-(fset 'load load)
-(re-export load-path)
-
-(fset 'eval
- (lambda (form)
- (eval form the-elisp-module)))
-
-(fset 'autoload
- (lambda args
- #t))
-
-(define-public current-load-list %nil)
+++ /dev/null
-(define-module (lang elisp primitives match)
- #:use-module (lang elisp internals fset)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 optargs))
-
-(define last-match #f)
-
-(fset 'string-match
- (lambda (regexp string . start)
-
- (define emacs-string-match
-
- (if (defined? 'make-emacs-regexp)
-
- ;; This is what we would do if we had an
- ;; Emacs-compatible regexp primitive, here called
- ;; `make-emacs-regexp'.
- (lambda (pattern str . args)
- (let ((rx (make-emacs-regexp pattern))
- (start (if (pair? args) (car args) 0)))
- (regexp-exec rx str start)))
-
- ;; But we don't have Emacs-compatible regexps, and I
- ;; don't think it's worthwhile at this stage to write
- ;; generic regexp conversion code. So work around the
- ;; discrepancies between Guile/libc and Emacs regexps by
- ;; substituting the regexps that actually occur in the
- ;; elisp code that we want to read.
- (lambda (pattern str . args)
- (let loop ((discrepancies '(("^[0-9]+\\.\\([0-9]+\\)" .
- "^[0-9]+\\.([0-9]+)"))))
- (or (null? discrepancies)
- (if (string=? pattern (caar discrepancies))
- (set! pattern (cdar discrepancies))
- (loop (cdr discrepancies)))))
- (apply string-match pattern str args))))
-
- (let ((match (apply emacs-string-match regexp string start)))
- (set! last-match
- (if match
- (apply append!
- (map (lambda (n)
- (list (match:start match n)
- (match:end match n)))
- (iota (match:count match))))
- #f)))
-
- (if last-match (car last-match) %nil)))
-
-(fset 'match-beginning
- (lambda (subexp)
- (list-ref last-match (* 2 subexp))))
-
-(fset 'match-end
- (lambda (subexp)
- (list-ref last-match (+ (* 2 subexp) 1))))
-
-(fset 'substring substring)
-
-(fset 'match-data
- (lambda* (#:optional integers reuse)
- last-match))
-
-(fset 'set-match-data
- (lambda (list)
- (set! last-match list)))
-
-(fset 'store-match-data 'set-match-data)
+++ /dev/null
-(define-module (lang elisp primitives numbers)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals null))
-
-(fset 'logior logior)
-(fset 'logand logand)
-(fset 'integerp (lambda->nil integer?))
-(fset '= =)
-(fset '< <)
-(fset '> >)
-(fset '<= <=)
-(fset '>= >=)
-(fset '* *)
-(fset '+ +)
-(fset '- -)
-(fset '1- 1-)
-(fset 'ash ash)
-
-(fset 'lsh
- (let ()
- (define (lsh num shift)
- (cond ((= shift 0)
- num)
- ((< shift 0)
- ;; Logical shift to the right. Do an arithmetic
- ;; shift and then mask out the sign bit.
- (lsh (logand (ash num -1) most-positive-fixnum)
- (+ shift 1)))
- (else
- ;; Logical shift to the left. Guile's ash will
- ;; always preserve the sign of the result, which is
- ;; not what we want for lsh, so we need to work
- ;; around this.
- (let ((new-sign-bit (ash (logand num
- (logxor most-positive-fixnum
- (ash most-positive-fixnum -1)))
- 1)))
- (lsh (logxor new-sign-bit
- (ash (logand num most-positive-fixnum) 1))
- (- shift 1))))))
- lsh))
-
-(fset 'numberp (lambda->nil number?))
+++ /dev/null
-(define-module (lang elisp primitives pure)
- #:use-module (lang elisp internals fset))
-
-;; Purification, unexec etc. are not yet implemented...
-
-(fset 'purecopy identity)
-
-(define-public purify-flag %nil)
+++ /dev/null
-(define-module (lang elisp primitives read)
- #:use-module (lang elisp internals fset))
-
-;;; MEGA HACK!!!!
-
-(fset 'read (lambda (str)
- (cond ((string=? str "?\\M-\\^@")
- -134217728)
- (else
- (with-input-from-string str read)))))
+++ /dev/null
-(define-module (lang elisp primitives signal)
- #:use-module (lang elisp internals signal)
- #:use-module (lang elisp internals fset))
-
-(fset 'signal signal)
-(fset 'error error)
+++ /dev/null
-(define-module (lang elisp primitives strings)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals null)
- #:use-module (lang elisp internals signal))
-
-(fset 'substring substring)
-
-(fset 'concat
- (lambda args
- (apply string-append
- (map (lambda (arg)
- (cond
- ((string? arg) arg)
- ((list? arg) (list->string arg))
- ((vector? arg) (list->string (vector->list arg)))
- (else (error "Wrong type argument for concat"))))
- args))))
-
-(fset 'string-to-number string->number)
-
-(fset 'number-to-string number->string)
-
-(fset 'string-lessp (lambda->nil string<?))
-(fset 'string< 'string-lessp)
-
-(fset 'aref
- (lambda (array idx)
- (cond ((vector? array) (vector-ref array idx))
- ((string? array) (char->integer (string-ref array idx)))
- (else (wta 'arrayp array 1)))))
-
-(fset 'aset
- (lambda (array idx newelt)
- (cond ((vector? array) (vector-set! array idx newelt))
- ((string? array) (string-set! array idx (integer->char newelt)))
- (else (wta 'arrayp array 1)))))
-
-(fset 'stringp (lambda->nil string?))
-
-(fset 'vector vector)
+++ /dev/null
-(define-module (lang elisp primitives symprop)
- #:use-module (lang elisp internals evaluation)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals null)
- #:use-module (lang elisp internals set)
- #:use-module (ice-9 optargs))
-
-;;; {Elisp Exports}
-
-(fset 'put set-symbol-property!)
-
-(fset 'get (lambda->nil symbol-property))
-
-(fset 'set set)
-
-(fset 'set-default 'set)
-
-(fset 'boundp
- (lambda (sym)
- (->nil (module-defined? the-elisp-module sym))))
-
-(fset 'default-boundp 'boundp)
-
-(fset 'symbol-value
- (lambda (sym)
- (value sym #t)))
-
-(fset 'default-value 'symbol-value)
-
-(fset 'symbolp
- (lambda (object)
- (or (symbol? object)
- (keyword? object)
- %nil)))
-
-(fset 'local-variable-if-set-p
- (lambda* (variable #:optional buffer)
- %nil))
-
-(fset 'symbol-name symbol->string)
+++ /dev/null
-(define-module (lang elisp primitives syntax)
- #:use-syntax (lang elisp expand)
- #:use-module (lang elisp internals evaluation)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals lambda)
- #:use-module (lang elisp internals set)
- #:use-module (lang elisp internals trace)
- #:use-module (lang elisp transform))
-
-;;; Define Emacs Lisp special forms as macros. This is more flexible
-;;; than handling them specially in the translator: allows them to be
-;;; redefined, and hopefully allows better source location tracking.
-
-;;; {Variables}
-
-(define (setq exp env)
- (cons begin
- (let loop ((sets (cdr exp)))
- (if (null? sets)
- '()
- (cons `(,set (,quote ,(car sets)) ,(transformer (cadr sets)))
- (loop (cddr sets)))))))
-
-(fset 'setq
- (procedure->memoizing-macro setq))
-
-(fset 'defvar
- (procedure->memoizing-macro
- (lambda (exp env)
- (trc 'defvar (cadr exp))
- (if (null? (cddr exp))
- `(,quote ,(cadr exp))
- `(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
- ,(setq (list (car exp) (cadr exp) (caddr exp)) env))
- (,quote ,(cadr exp)))))))
-
-(fset 'defconst
- (procedure->memoizing-macro
- (lambda (exp env)
- (trc 'defconst (cadr exp))
- `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
- (,quote ,(cadr exp))))))
-
-;;; {lambda, function and macro definitions}
-
-(fset 'lambda
- (procedure->memoizing-macro
- (lambda (exp env)
- (transform-lambda/interactive exp '<elisp-lambda>))))
-
-(fset 'defun
- (procedure->memoizing-macro
- (lambda (exp env)
- (trc 'defun (cadr exp))
- `(,begin (,fset (,quote ,(cadr exp))
- ,(transform-lambda/interactive (cdr exp)
- (symbol-append '<elisp-defun:
- (cadr exp)
- '>)))
- (,quote ,(cadr exp))))))
-
-(fset 'interactive
- (procedure->memoizing-macro
- (lambda (exp env)
- (fluid-set! interactive-spec exp)
- #f)))
-
-(fset 'defmacro
- (procedure->memoizing-macro
- (lambda (exp env)
- (trc 'defmacro (cadr exp))
- (call-with-values (lambda () (parse-formals (caddr exp)))
- (lambda (required optional rest)
- (let ((num-required (length required))
- (num-optional (length optional)))
- `(,begin (,fset (,quote ,(cadr exp))
- (,procedure->memoizing-macro
- (,lambda (exp1 env1)
- (,trc (,quote using) (,quote ,(cadr exp)))
- (,let* ((%--args (,cdr exp1))
- (%--num-args (,length %--args)))
- (,cond ((,< %--num-args ,num-required)
- (,error "Wrong number of args (not enough required args)"))
- ,@(if rest
- '()
- `(((,> %--num-args ,(+ num-required num-optional))
- (,error "Wrong number of args (too many args)"))))
- (else (,transformer
- (, @bind ,(append (map (lambda (i)
- (list (list-ref required i)
- `(,list-ref %--args ,i)))
- (iota num-required))
- (map (lambda (i)
- (let ((i+nr (+ i num-required)))
- (list (list-ref optional i)
- `(,if (,> %--num-args ,i+nr)
- (,list-ref %--args ,i+nr)
- ,%nil))))
- (iota num-optional))
- (if rest
- (list (list rest
- `(,if (,> %--num-args
- ,(+ num-required
- num-optional))
- (,list-tail %--args
- ,(+ num-required
- num-optional))
- ,%nil)))
- '()))
- ,@(map transformer (cdddr exp)))))))))))))))))
-
-;;; {Sequencing}
-
-(fset 'progn
- (procedure->memoizing-macro
- (lambda (exp env)
- `(,begin ,@(map transformer (cdr exp))))))
-
-(fset 'prog1
- (procedure->memoizing-macro
- (lambda (exp env)
- `(,let ((%--res1 ,(transformer (cadr exp))))
- ,@(map transformer (cddr exp))
- %--res1))))
-
-(fset 'prog2
- (procedure->memoizing-macro
- (lambda (exp env)
- `(,begin ,(transformer (cadr exp))
- (,let ((%--res2 ,(transformer (caddr exp))))
- ,@(map transformer (cdddr exp))
- %--res2)))))
-
-;;; {Conditionals}
-
-(fset 'if
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((else-case (cdddr exp)))
- (cond ((null? else-case)
- `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
- ((null? (cdr else-case))
- `(,nil-cond ,(transformer (cadr exp))
- ,(transformer (caddr exp))
- ,(transformer (car else-case))))
- (else
- `(,nil-cond ,(transformer (cadr exp))
- ,(transformer (caddr exp))
- (,begin ,@(map transformer else-case)))))))))
-
-(fset 'and
- (procedure->memoizing-macro
- (lambda (exp env)
- (cond ((null? (cdr exp)) #t)
- ((null? (cddr exp)) (transformer (cadr exp)))
- (else
- (cons nil-cond
- (let loop ((args (cdr exp)))
- (if (null? (cdr args))
- (list (transformer (car args)))
- (cons (list not (transformer (car args)))
- (cons %nil
- (loop (cdr args))))))))))))
-
-;;; NIL-COND expressions have the form:
-;;;
-;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
-;;;
-;;; The CONDs are evaluated in order until one of them returns true
-;;; (in the Elisp sense, so not including empty lists). If a COND
-;;; returns true, its corresponding VAL is evaluated and returned,
-;;; except if that VAL is the unspecified value, in which case the
-;;; result of evaluating the COND is returned. If none of the COND's
-;;; returns true, ELSEVAL is evaluated and its value returned.
-
-(define <-- *unspecified*)
-
-(fset 'or
- (procedure->memoizing-macro
- (lambda (exp env)
- (cond ((null? (cdr exp)) %nil)
- ((null? (cddr exp)) (transformer (cadr exp)))
- (else
- (cons nil-cond
- (let loop ((args (cdr exp)))
- (if (null? (cdr args))
- (list (transformer (car args)))
- (cons (transformer (car args))
- (cons <--
- (loop (cdr args))))))))))))
-
-(fset 'cond
- (procedure->memoizing-macro
- (lambda (exp env)
- (if (null? (cdr exp))
- %nil
- (cons
- nil-cond
- (let loop ((clauses (cdr exp)))
- (if (null? clauses)
- (list %nil)
- (let ((clause (car clauses)))
- (if (eq? (car clause) #t)
- (cond ((null? (cdr clause)) (list #t))
- ((null? (cddr clause))
- (list (transformer (cadr clause))))
- (else `((,begin ,@(map transformer (cdr clause))))))
- (cons (transformer (car clause))
- (cons (cond ((null? (cdr clause)) <--)
- ((null? (cddr clause))
- (transformer (cadr clause)))
- (else
- `(,begin ,@(map transformer (cdr clause)))))
- (loop (cdr clauses)))))))))))))
-
-(fset 'while
- (procedure->memoizing-macro
- (lambda (exp env)
- `((,letrec ((%--while (,lambda ()
- (,nil-cond ,(transformer (cadr exp))
- (,begin ,@(map transformer (cddr exp))
- (%--while))
- ,%nil))))
- %--while)))))
-
-;;; {Local binding}
-
-(fset 'let
- (procedure->memoizing-macro
- (lambda (exp env)
- `(, @bind ,(map (lambda (binding)
- (trc 'let binding)
- (if (pair? binding)
- `(,(car binding) ,(transformer (cadr binding)))
- `(,binding ,%nil)))
- (cadr exp))
- ,@(map transformer (cddr exp))))))
-
-(fset 'let*
- (procedure->memoizing-macro
- (lambda (exp env)
- (if (null? (cadr exp))
- `(,begin ,@(map transformer (cddr exp)))
- (car (let loop ((bindings (cadr exp)))
- (if (null? bindings)
- (map transformer (cddr exp))
- `((, @bind (,(let ((binding (car bindings)))
- (if (pair? binding)
- `(,(car binding) ,(transformer (cadr binding)))
- `(,binding ,%nil))))
- ,@(loop (cdr bindings)))))))))))
-
-;;; {Exception handling}
-
-(fset 'unwind-protect
- (procedure->memoizing-macro
- (lambda (exp env)
- (trc 'unwind-protect (cadr exp))
- `(,let ((%--throw-args #f))
- (,catch #t
- (,lambda ()
- ,(transformer (cadr exp)))
- (,lambda args
- (,set! %--throw-args args)))
- ,@(map transformer (cddr exp))
- (,if %--throw-args
- (,apply ,throw %--throw-args))))))
+++ /dev/null
-(define-module (lang elisp primitives system)
- #:use-module (lang elisp internals fset))
-
-(fset 'system-name
- (lambda ()
- (vector-ref (uname) 1)))
-
-(define-public system-type
- (let ((uname (vector-ref (uname) 0)))
- (if (string=? uname "Linux")
- "gnu/linux"
- uname)))
-
-(define-public system-configuration "i386-suse-linux") ;FIXME
+++ /dev/null
-(define-module (lang elisp primitives time)
- #:use-module (lang elisp internals time)
- #:use-module (lang elisp internals fset)
- #:use-module (ice-9 optargs))
-
-(fset 'current-time
- (lambda ()
- (let ((now (current-time)))
- (list (ash now -16)
- (logand now (- (ash 1 16) 1))
- 0))))
-
-(fset 'format-time-string format-time-string)
-
-(fset 'current-time-string
- (lambda* (#:optional specified-time)
- (format-time-string "%a %b %e %T %Y" specified-time)))
+++ /dev/null
-(define-module (lang elisp transform)
- #:use-syntax (lang elisp expand)
- #:use-module (lang elisp internals trace)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals evaluation)
- #:use-module (ice-9 session)
- #:export (transformer transform))
-
-;;; A note on the difference between `(transform-* (cdr x))' and `(map
-;;; transform-* (cdr x))'.
-;;;
-;;; In most cases, none, as most of the transform-* functions are
-;;; recursive.
-;;;
-;;; However, if (cdr x) is not a proper list, the `map' version will
-;;; signal an error immediately, whereas the non-`map' version will
-;;; produce a similarly improper list as its transformed output. In
-;;; some cases, improper lists are allowed, so at least these cases
-;;; require non-`map'.
-;;;
-;;; Therefore we use the non-`map' approach in most cases below, but
-;;; `map' in transform-application, since in the application case we
-;;; know that `(func arg . args)' is an error. It would probably be
-;;; better for the transform-application case to check for an improper
-;;; list explicitly and signal a more explicit error.
-
-(define (syntax-error x)
- (error "Syntax error in expression" x))
-
-(define scheme
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((exp (cadr exp))
- (module (cddr exp)))
- (let ((m (if (null? module)
- the-root-module
- (save-module-excursion
- (lambda ()
- ;; In order for `resolve-module' to work as
- ;; expected, the current module must contain the
- ;; `app' variable. This is not true for #:pure
- ;; modules, specifically (lang elisp base). So,
- ;; switch to the root module (guile) before calling
- ;; resolve-module.
- (set-current-module the-root-module)
- (resolve-module (car module)))))))
- (let ((x `(,eval (,quote ,exp) ,m)))
- ;;(write x)
- ;;(newline)
- x))))))
-
-(define (transformer x)
- (cond ((pair? x)
- (cond ((symbol? (car x))
- (case (car x)
- ;; Allow module-related forms through intact.
- ((define-module use-modules use-syntax)
- x)
- ;; Escape to Scheme.
- ((scheme)
- (cons-source x scheme (cdr x)))
- ;; Quoting.
- ((quote function)
- (cons-source x quote (transform-quote (cdr x))))
- ((quasiquote)
- (cons-source x quasiquote (transform-quasiquote (cdr x))))
- ;; Anything else is a function or macro application.
- (else (transform-application x))))
- ((and (pair? (car x))
- (eq? (caar x) 'quasiquote))
- (transformer (car x)))
- (else (syntax-error x))))
- (else
- (transform-datum x))))
-
-(define (transform-datum x)
- (cond ((eq? x 'nil) %nil)
- ((eq? x 't) #t)
- ;; Could add other translations here, notably `?A' -> 65 etc.
- (else x)))
-
-(define (transform-quote x)
- (trc 'transform-quote x)
- (cond ((not (pair? x))
- (transform-datum x))
- (else
- (cons-source x
- (transform-quote (car x))
- (transform-quote (cdr x))))))
-
-(define (transform-quasiquote x)
- (trc 'transform-quasiquote x)
- (cond ((not (pair? x))
- (transform-datum x))
- ((symbol? (car x))
- (case (car x)
- ((unquote) (list 'unquote (transformer (cadr x))))
- ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
- (else (cons-source x
- (transform-datum (car x))
- (transform-quasiquote (cdr x))))))
- (else
- (cons-source x
- (transform-quasiquote (car x))
- (transform-quasiquote (cdr x))))))
-
-(define (transform-application x)
- (cons-source x @fop `(,(car x) (,transformer-macro ,@(map transform-quote (cdr x))))))
-
-(define transformer-macro
- (procedure->memoizing-macro
- (let ((cdr cdr))
- (lambda (exp env)
- (cons-source exp list (map transformer (cdr exp)))))))
-
-(define transform transformer)
+++ /dev/null
-(define-module (lang elisp variables))
-
-;;; The only purpose of this module is to provide a place where the
-;;; variables holding Elisp function definitions can be bound to
-;;; symbols.
-;;;
-;;; This can be useful when looking at unmemoized procedure source
-;;; code for Elisp functions and macros. Elisp function and macro
-;;; symbols get memoized into variables. When the unmemoizer tries to
-;;; unmemoize a variables, it does so by looking for a symbol that is
-;;; bound to that variable, starting from the module in which the
-;;; function or macro was defined and then trying the interfaces on
-;;; that module's uses list. If it can't find any such symbol, it
-;;; returns the symbol '???.
-;;;
-;;; Normally we don't want to bind Elisp function definition variables
-;;; to symbols that are visible from the Elisp evaluation module (lang
-;;; elisp base), because they would pollute the namespace available
-;;; to Elisp variables. On the other hand, if we are trying to debug
-;;; something, and looking at unmemoized source code, it's far more
-;;; informative if that code has symbols that indicate the Elisp
-;;; function being called than if it just says ??? everywhere.
-;;;
-;;; So we have a compromise, which achieves a reasonable balance of
-;;; correctness (for general operation) and convenience (for
-;;; debugging).
-;;;
-;;; 1. We bind Elisp function definition variables to symbols in this
-;;; module (lang elisp variables).
-;;;
-;;; 2. By default, the Elisp evaluation module (lang elisp base) does
-;;; not use (lang elisp variables), so the Elisp variable namespace
-;;; stays clean.
-;;;
-;;; 3. When debugging, a simple (named-module-use! '(lang elisp base)
-;;; '(lang elisp variables)) makes the function definition symbols
-;;; visible in (lang elisp base) so that the unmemoizer can find
-;;; them, which makes the unmemoized source code much easier to read.
-;;;
-;;; 4. To reduce the effects of namespace pollution even after step 3,
-;;; the symbols that we bind are all prefixed with `<elisp' and
-;;; suffixed with `>'.
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-versions lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf
+# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --libtool --macro-prefix=gl --no-vc-files alignof alloca-opt announce-gen autobuild byteswap canonicalize-lgpl duplocale environ extensions flock fpieee full-read full-write gendocs gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton lib-symbol-versions lib-symbol-visibility libunistring locale maintainer-makefile putenv stdlib strcase strftime striconveh string verify version-etc-fsf vsnprintf warnings
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
EXTRA_libgnu_la_SOURCES =
libgnu_la_LDFLAGS = $(AM_LDFLAGS)
+## begin gnulib module alignof
+
+
+EXTRA_DIST += alignof.h
+
+## end gnulib module alignof
+
## begin gnulib module alloca-opt
BUILT_SOURCES += $(ALLOCA_H)
# We need the following in order to create <alloca.h> when the system
# doesn't have one that works with the given compiler.
alloca.h: alloca.in.h
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
cat $(srcdir)/alloca.in.h; \
- } > $@-t
+ } > $@-t && \
mv -f $@-t $@
MOSTLYCLEANFILES += alloca.h alloca.h-t
## end gnulib module alloca-opt
+## begin gnulib module announce-gen
+
+
+EXTRA_DIST += $(top_srcdir)/build-aux/announce-gen
+
+## end gnulib module announce-gen
+
+## begin gnulib module arpa_inet
+
+BUILT_SOURCES += $(ARPA_INET_H)
+
+# We need the following in order to create <arpa/inet.h> when the system
+# doesn't have one.
+arpa/inet.h: arpa_inet.in.h
+ $(AM_V_at)$(MKDIR_P) arpa
+ $(AM_V_GEN)rm -f $@-t $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_ARPA_INET_H''@|$(NEXT_ARPA_INET_H)|g' \
+ -e 's|@''HAVE_ARPA_INET_H''@|$(HAVE_ARPA_INET_H)|g' \
+ -e 's|@''GNULIB_INET_NTOP''@|$(GNULIB_INET_NTOP)|g' \
+ -e 's|@''GNULIB_INET_PTON''@|$(GNULIB_INET_PTON)|g' \
+ -e 's|@''HAVE_DECL_INET_NTOP''@|$(HAVE_DECL_INET_NTOP)|g' \
+ -e 's|@''HAVE_DECL_INET_PTON''@|$(HAVE_DECL_INET_PTON)|g' \
+ -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ < $(srcdir)/arpa_inet.in.h; \
+ } > $@-t && \
+ mv $@-t $@
+MOSTLYCLEANFILES += arpa/inet.h arpa/inet.h-t
+MOSTLYCLEANDIRS += arpa
+
+EXTRA_DIST += arpa_inet.in.h
+
+## end gnulib module arpa_inet
+
## begin gnulib module byteswap
BUILT_SOURCES += $(BYTESWAP_H)
# We need the following in order to create <byteswap.h> when the system
# doesn't have one.
byteswap.h: byteswap.in.h
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
cat $(srcdir)/byteswap.in.h; \
- } > $@-t
+ } > $@-t && \
mv -f $@-t $@
MOSTLYCLEANFILES += byteswap.h byteswap.h-t
## begin gnulib module canonicalize-lgpl
-EXTRA_DIST += canonicalize-lgpl.c canonicalize.h
+EXTRA_DIST += canonicalize-lgpl.c
EXTRA_libgnu_la_SOURCES += canonicalize-lgpl.c
# The Automake-defined pkg* macros are appended, in the order
# listed in the Automake 1.10a+ documentation.
configmake.h: Makefile
- rm -f $@-t
+ $(AM_V_GEN)rm -f $@-t && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
echo '#define PREFIX "$(prefix)"'; \
echo '#define EXEC_PREFIX "$(exec_prefix)"'; \
echo '#define PKGINCLUDEDIR "$(pkgincludedir)"'; \
echo '#define PKGLIBDIR "$(pkglibdir)"'; \
echo '#define PKGLIBEXECDIR "$(pkglibexecdir)"'; \
- } | sed '/""/d' > $@-t
+ } | sed '/""/d' > $@-t && \
if test -f $@ && cmp $@-t $@ > /dev/null; then \
rm -f $@-t; \
else \
## end gnulib module configmake
-## begin gnulib module count-one-bits
+## begin gnulib module duplocale
+
+EXTRA_DIST += duplocale.c
-EXTRA_DIST += count-one-bits.h
+EXTRA_libgnu_la_SOURCES += duplocale.c
-## end gnulib module count-one-bits
+## end gnulib module duplocale
## begin gnulib module errno
# We need the following in order to create <errno.h> when the system
# doesn't have one that is POSIX compliant.
errno.h: errno.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''EOVERFLOW_HIDDEN''@|$(EOVERFLOW_HIDDEN)|g' \
-e 's|@''EOVERFLOW_VALUE''@|$(EOVERFLOW_VALUE)|g' \
< $(srcdir)/errno.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += errno.h errno.h-t
# We need the following in order to create <float.h> when the system
# doesn't have one that works with the given compiler.
float.h: float.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''NEXT_FLOAT_H''@|$(NEXT_FLOAT_H)|g' \
< $(srcdir)/float.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += float.h float.h-t
## end gnulib module full-write
-## begin gnulib module getpagesize
+## begin gnulib module gendocs
+
+
+EXTRA_DIST += $(top_srcdir)/build-aux/gendocs.sh
+
+## end gnulib module gendocs
+
+## begin gnulib module gettext-h
+
+libgnu_la_SOURCES += gettext.h
+
+## end gnulib module gettext-h
+
+## begin gnulib module gitlog-to-changelog
+
+
+EXTRA_DIST += $(top_srcdir)/build-aux/gitlog-to-changelog
+
+## end gnulib module gitlog-to-changelog
+
+## begin gnulib module gnu-web-doc-update
-EXTRA_DIST += getpagesize.c
+EXTRA_DIST += $(top_srcdir)/build-aux/gnu-web-doc-update
-EXTRA_libgnu_la_SOURCES += getpagesize.c
+## end gnulib module gnu-web-doc-update
-## end gnulib module getpagesize
+## begin gnulib module gnumakefile
+
+distclean-local: clean-GNUmakefile
+clean-GNUmakefile:
+ test x'$(VPATH)' != x && rm -f $(top_builddir)/GNUmakefile || :
+
+EXTRA_DIST += $(top_srcdir)/GNUmakefile
+
+## end gnulib module gnumakefile
+
+## begin gnulib module gnupload
+
+
+EXTRA_DIST += $(top_srcdir)/build-aux/gnupload
+
+## end gnulib module gnupload
## begin gnulib module gperf
# We need the following in order to create <iconv.h> when the system
# doesn't have one that works with the given compiler.
iconv.h: iconv.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''REPLACE_ICONV_OPEN''@|$(REPLACE_ICONV_OPEN)|g' \
-e 's|@''REPLACE_ICONV_UTF''@|$(REPLACE_ICONV_UTF)|g' \
< $(srcdir)/iconv.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += iconv.h iconv.h-t
iconv_open-osf.h: iconv_open-osf.gperf
$(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf > $(srcdir)/iconv_open-osf.h-t
mv $(srcdir)/iconv_open-osf.h-t $(srcdir)/iconv_open-osf.h
-BUILT_SOURCES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h
-MOSTLYCLEANFILES += iconv_open-aix.h-t iconv_open-hpux.h-t iconv_open-irix.h-t iconv_open-osf.h-t
-MAINTAINERCLEANFILES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h
-EXTRA_DIST += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h
+iconv_open-solaris.h: iconv_open-solaris.gperf
+ $(GPERF) -m 10 $(srcdir)/iconv_open-solaris.gperf > $(srcdir)/iconv_open-solaris.h-t
+ mv $(srcdir)/iconv_open-solaris.h-t $(srcdir)/iconv_open-solaris.h
+BUILT_SOURCES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h iconv_open-solaris.h
+MOSTLYCLEANFILES += iconv_open-aix.h-t iconv_open-hpux.h-t iconv_open-irix.h-t iconv_open-osf.h-t iconv_open-solaris.h-t
+MAINTAINERCLEANFILES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h iconv_open-solaris.h
+EXTRA_DIST += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h iconv_open-solaris.h
-EXTRA_DIST += iconv.in.h iconv_open-aix.gperf iconv_open-hpux.gperf iconv_open-irix.gperf iconv_open-osf.gperf iconv_open.c
+EXTRA_DIST += iconv.in.h iconv_open-aix.gperf iconv_open-hpux.gperf iconv_open-irix.gperf iconv_open-osf.gperf iconv_open-solaris.gperf iconv_open.c
EXTRA_libgnu_la_SOURCES += iconv_open.c
## end gnulib module iconv_open-utf
+## begin gnulib module inet_ntop
+
+
+EXTRA_DIST += inet_ntop.c
+
+EXTRA_libgnu_la_SOURCES += inet_ntop.c
+
+## end gnulib module inet_ntop
+
+## begin gnulib module inet_pton
+
+
+EXTRA_DIST += inet_pton.c
+
+EXTRA_libgnu_la_SOURCES += inet_pton.c
+
+## end gnulib module inet_pton
+
## begin gnulib module lib-symbol-visibility
# The value of $(CFLAG_VISIBILITY) needs to be added to the CFLAGS for the
fi
charset.alias: config.charset
- rm -f t-$@ $@
- $(SHELL) $(srcdir)/config.charset '$(host)' > t-$@
+ $(AM_V_GEN)rm -f t-$@ $@ && \
+ $(SHELL) $(srcdir)/config.charset '$(host)' > t-$@ && \
mv t-$@ $@
SUFFIXES += .sed .sin
.sin.sed:
- rm -f t-$@ $@
- sed -e '/^#/d' -e 's/@''PACKAGE''@/$(PACKAGE)/g' $< > t-$@
+ $(AM_V_GEN)rm -f t-$@ $@ && \
+ sed -e '/^#/d' -e 's/@''PACKAGE''@/$(PACKAGE)/g' $< > t-$@ && \
mv t-$@ $@
CLEANFILES += charset.alias ref-add.sed ref-del.sed
## end gnulib module localcharset
+## begin gnulib module locale
+
+BUILT_SOURCES += $(LOCALE_H)
+
+# We need the following in order to create <locale.h> when the system
+# doesn't have one that provides all definitions.
+locale.h: locale.in.h
+ $(AM_V_GEN)rm -f $@-t $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_LOCALE_H''@|$(NEXT_LOCALE_H)|g' \
+ -e 's|@''GNULIB_DUPLOCALE''@|$(GNULIB_DUPLOCALE)|g' \
+ -e 's|@''HAVE_XLOCALE_H''@|$(HAVE_XLOCALE_H)|g' \
+ -e 's|@''REPLACE_DUPLOCALE''@|$(REPLACE_DUPLOCALE)|g' \
+ < $(srcdir)/locale.in.h; \
+ } > $@-t && \
+ mv $@-t $@
+MOSTLYCLEANFILES += locale.h locale.h-t
+
+EXTRA_DIST += locale.in.h
+
+## end gnulib module locale
+
+## begin gnulib module lstat
+
+
+EXTRA_DIST += lstat.c
+
+EXTRA_libgnu_la_SOURCES += lstat.c
+
+## end gnulib module lstat
+
+## begin gnulib module maintainer-makefile
+
+EXTRA_DIST += $(top_srcdir)/maint.mk
+
+## end gnulib module maintainer-makefile
+
## begin gnulib module malloc-posix
## end gnulib module memchr
+## begin gnulib module netinet_in
+
+BUILT_SOURCES += $(NETINET_IN_H)
+
+# We need the following in order to create <netinet/in.h> when the system
+# doesn't have one.
+netinet/in.h: netinet_in.in.h
+ $(AM_V_at)$(MKDIR_P) netinet
+ $(AM_V_GEN)rm -f $@-t $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_NETINET_IN_H''@|$(NEXT_NETINET_IN_H)|g' \
+ -e 's|@''HAVE_NETINET_IN_H''@|$(HAVE_NETINET_IN_H)|g' \
+ < $(srcdir)/netinet_in.in.h; \
+ } > $@-t && \
+ mv $@-t $@
+MOSTLYCLEANFILES += netinet/in.h netinet/in.h-t
+MOSTLYCLEANDIRS += netinet
+
+EXTRA_DIST += netinet_in.in.h
+
+## end gnulib module netinet_in
+
## begin gnulib module pathmax
## end gnulib module size_max
+## begin gnulib module stat
+
+
+EXTRA_DIST += stat.c
+
+EXTRA_libgnu_la_SOURCES += stat.c
+
+## end gnulib module stat
+
+## begin gnulib module stdarg
+
+BUILT_SOURCES += $(STDARG_H)
+
+# We need the following in order to create <stdarg.h> when the system
+# doesn't have one that works with the given compiler.
+stdarg.h: stdarg.in.h
+ $(AM_V_GEN)rm -f $@-t $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_STDARG_H''@|$(NEXT_STDARG_H)|g' \
+ < $(srcdir)/stdarg.in.h; \
+ } > $@-t && \
+ mv $@-t $@
+MOSTLYCLEANFILES += stdarg.h stdarg.h-t
+
+EXTRA_DIST += stdarg.in.h
+
+## end gnulib module stdarg
+
## begin gnulib module stdbool
BUILT_SOURCES += $(STDBOOL_H)
# We need the following in order to create <stdbool.h> when the system
# doesn't have one that works.
stdbool.h: stdbool.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's/@''HAVE__BOOL''@/$(HAVE__BOOL)/g' < $(srcdir)/stdbool.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += stdbool.h stdbool.h-t
## end gnulib module stdbool
+## begin gnulib module stddef
+
+BUILT_SOURCES += $(STDDEF_H)
+
+# We need the following in order to create <stddef.h> when the system
+# doesn't have one that works with the given compiler.
+stddef.h: stddef.in.h
+ $(AM_V_GEN)rm -f $@-t $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_STDDEF_H''@|$(NEXT_STDDEF_H)|g' \
+ -e 's|@''HAVE_WCHAR_T''@|$(HAVE_WCHAR_T)|g' \
+ -e 's|@''REPLACE_NULL''@|$(REPLACE_NULL)|g' \
+ < $(srcdir)/stddef.in.h; \
+ } > $@-t && \
+ mv $@-t $@
+MOSTLYCLEANFILES += stddef.h stddef.h-t
+
+EXTRA_DIST += stddef.in.h
+
+## end gnulib module stddef
+
## begin gnulib module stdint
BUILT_SOURCES += $(STDINT_H)
# We need the following in order to create <stdint.h> when the system
# doesn't have one that works with the given compiler.
stdint.h: stdint.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's/@''HAVE_STDINT_H''@/$(HAVE_STDINT_H)/g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's/@''HAVE_SIGNED_WINT_T''@/$(HAVE_SIGNED_WINT_T)/g' \
-e 's/@''WINT_T_SUFFIX''@/$(WINT_T_SUFFIX)/g' \
< $(srcdir)/stdint.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += stdint.h stdint.h-t
# We need the following in order to create <stdio.h> when the system
# doesn't have one that works with the given compiler.
stdio.h: stdio.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''NEXT_STDIO_H''@|$(NEXT_STDIO_H)|g' \
- -e 's|@''GNULIB_FPRINTF''@|$(GNULIB_FPRINTF)|g' \
- -e 's|@''GNULIB_FPRINTF_POSIX''@|$(GNULIB_FPRINTF_POSIX)|g' \
- -e 's|@''GNULIB_PRINTF''@|$(GNULIB_PRINTF)|g' \
- -e 's|@''GNULIB_PRINTF_POSIX''@|$(GNULIB_PRINTF_POSIX)|g' \
- -e 's|@''GNULIB_SNPRINTF''@|$(GNULIB_SNPRINTF)|g' \
- -e 's|@''GNULIB_SPRINTF_POSIX''@|$(GNULIB_SPRINTF_POSIX)|g' \
- -e 's|@''GNULIB_VFPRINTF''@|$(GNULIB_VFPRINTF)|g' \
- -e 's|@''GNULIB_VFPRINTF_POSIX''@|$(GNULIB_VFPRINTF_POSIX)|g' \
- -e 's|@''GNULIB_VPRINTF''@|$(GNULIB_VPRINTF)|g' \
- -e 's|@''GNULIB_VPRINTF_POSIX''@|$(GNULIB_VPRINTF_POSIX)|g' \
- -e 's|@''GNULIB_VSNPRINTF''@|$(GNULIB_VSNPRINTF)|g' \
- -e 's|@''GNULIB_VSPRINTF_POSIX''@|$(GNULIB_VSPRINTF_POSIX)|g' \
-e 's|@''GNULIB_DPRINTF''@|$(GNULIB_DPRINTF)|g' \
- -e 's|@''GNULIB_VDPRINTF''@|$(GNULIB_VDPRINTF)|g' \
- -e 's|@''GNULIB_VASPRINTF''@|$(GNULIB_VASPRINTF)|g' \
- -e 's|@''GNULIB_OBSTACK_PRINTF''@|$(GNULIB_OBSTACK_PRINTF)|g' \
- -e 's|@''GNULIB_OBSTACK_PRINTF_POSIX''@|$(GNULIB_OBSTACK_PRINTF_POSIX)|g' \
+ -e 's|@''GNULIB_FCLOSE''@|$(GNULIB_FCLOSE)|g' \
+ -e 's|@''GNULIB_FFLUSH''@|$(GNULIB_FFLUSH)|g' \
-e 's|@''GNULIB_FOPEN''@|$(GNULIB_FOPEN)|g' \
+ -e 's|@''GNULIB_FPRINTF''@|$(GNULIB_FPRINTF)|g' \
+ -e 's|@''GNULIB_FPRINTF_POSIX''@|$(GNULIB_FPRINTF_POSIX)|g' \
+ -e 's|@''GNULIB_FPURGE''@|$(GNULIB_FPURGE)|g' \
+ -e 's|@''GNULIB_FPUTC''@|$(GNULIB_FPUTC)|g' \
+ -e 's|@''GNULIB_FPUTS''@|$(GNULIB_FPUTS)|g' \
-e 's|@''GNULIB_FREOPEN''@|$(GNULIB_FREOPEN)|g' \
-e 's|@''GNULIB_FSEEK''@|$(GNULIB_FSEEK)|g' \
-e 's|@''GNULIB_FSEEKO''@|$(GNULIB_FSEEKO)|g' \
-e 's|@''GNULIB_FTELL''@|$(GNULIB_FTELL)|g' \
-e 's|@''GNULIB_FTELLO''@|$(GNULIB_FTELLO)|g' \
- -e 's|@''GNULIB_FFLUSH''@|$(GNULIB_FFLUSH)|g' \
- -e 's|@''GNULIB_FPURGE''@|$(GNULIB_FPURGE)|g' \
- -e 's|@''GNULIB_FCLOSE''@|$(GNULIB_FCLOSE)|g' \
- -e 's|@''GNULIB_FPUTC''@|$(GNULIB_FPUTC)|g' \
- -e 's|@''GNULIB_PUTC''@|$(GNULIB_PUTC)|g' \
- -e 's|@''GNULIB_PUTCHAR''@|$(GNULIB_PUTCHAR)|g' \
- -e 's|@''GNULIB_FPUTS''@|$(GNULIB_FPUTS)|g' \
- -e 's|@''GNULIB_PUTS''@|$(GNULIB_PUTS)|g' \
-e 's|@''GNULIB_FWRITE''@|$(GNULIB_FWRITE)|g' \
-e 's|@''GNULIB_GETDELIM''@|$(GNULIB_GETDELIM)|g' \
-e 's|@''GNULIB_GETLINE''@|$(GNULIB_GETLINE)|g' \
+ -e 's|@''GNULIB_OBSTACK_PRINTF''@|$(GNULIB_OBSTACK_PRINTF)|g' \
+ -e 's|@''GNULIB_OBSTACK_PRINTF_POSIX''@|$(GNULIB_OBSTACK_PRINTF_POSIX)|g' \
-e 's|@''GNULIB_PERROR''@|$(GNULIB_PERROR)|g' \
+ -e 's|@''GNULIB_POPEN''@|$(GNULIB_POPEN)|g' \
+ -e 's|@''GNULIB_PRINTF''@|$(GNULIB_PRINTF)|g' \
+ -e 's|@''GNULIB_PRINTF_POSIX''@|$(GNULIB_PRINTF_POSIX)|g' \
+ -e 's|@''GNULIB_PUTC''@|$(GNULIB_PUTC)|g' \
+ -e 's|@''GNULIB_PUTCHAR''@|$(GNULIB_PUTCHAR)|g' \
+ -e 's|@''GNULIB_PUTS''@|$(GNULIB_PUTS)|g' \
+ -e 's|@''GNULIB_REMOVE''@|$(GNULIB_REMOVE)|g' \
+ -e 's|@''GNULIB_RENAME''@|$(GNULIB_RENAME)|g' \
+ -e 's|@''GNULIB_RENAMEAT''@|$(GNULIB_RENAMEAT)|g' \
+ -e 's|@''GNULIB_SNPRINTF''@|$(GNULIB_SNPRINTF)|g' \
+ -e 's|@''GNULIB_SPRINTF_POSIX''@|$(GNULIB_SPRINTF_POSIX)|g' \
-e 's|@''GNULIB_STDIO_H_SIGPIPE''@|$(GNULIB_STDIO_H_SIGPIPE)|g' \
- -e 's|@''REPLACE_STDIO_WRITE_FUNCS''@|$(REPLACE_STDIO_WRITE_FUNCS)|g' \
- -e 's|@''REPLACE_FPRINTF''@|$(REPLACE_FPRINTF)|g' \
- -e 's|@''REPLACE_VFPRINTF''@|$(REPLACE_VFPRINTF)|g' \
- -e 's|@''REPLACE_PRINTF''@|$(REPLACE_PRINTF)|g' \
- -e 's|@''REPLACE_VPRINTF''@|$(REPLACE_VPRINTF)|g' \
- -e 's|@''REPLACE_SNPRINTF''@|$(REPLACE_SNPRINTF)|g' \
+ -e 's|@''GNULIB_VASPRINTF''@|$(GNULIB_VASPRINTF)|g' \
+ -e 's|@''GNULIB_VDPRINTF''@|$(GNULIB_VDPRINTF)|g' \
+ -e 's|@''GNULIB_VFPRINTF''@|$(GNULIB_VFPRINTF)|g' \
+ -e 's|@''GNULIB_VFPRINTF_POSIX''@|$(GNULIB_VFPRINTF_POSIX)|g' \
+ -e 's|@''GNULIB_VPRINTF''@|$(GNULIB_VPRINTF)|g' \
+ -e 's|@''GNULIB_VPRINTF_POSIX''@|$(GNULIB_VPRINTF_POSIX)|g' \
+ -e 's|@''GNULIB_VSNPRINTF''@|$(GNULIB_VSNPRINTF)|g' \
+ -e 's|@''GNULIB_VSPRINTF_POSIX''@|$(GNULIB_VSPRINTF_POSIX)|g' \
+ -e 's|@''HAVE_DECL_FPURGE''@|$(HAVE_DECL_FPURGE)|g' \
+ -e 's|@''HAVE_DECL_GETDELIM''@|$(HAVE_DECL_GETDELIM)|g' \
+ -e 's|@''HAVE_DECL_GETLINE''@|$(HAVE_DECL_GETLINE)|g' \
+ -e 's|@''HAVE_DECL_OBSTACK_PRINTF''@|$(HAVE_DECL_OBSTACK_PRINTF)|g' \
-e 's|@''HAVE_DECL_SNPRINTF''@|$(HAVE_DECL_SNPRINTF)|g' \
- -e 's|@''REPLACE_VSNPRINTF''@|$(REPLACE_VSNPRINTF)|g' \
-e 's|@''HAVE_DECL_VSNPRINTF''@|$(HAVE_DECL_VSNPRINTF)|g' \
- -e 's|@''REPLACE_SPRINTF''@|$(REPLACE_SPRINTF)|g' \
- -e 's|@''REPLACE_VSPRINTF''@|$(REPLACE_VSPRINTF)|g' \
-e 's|@''HAVE_DPRINTF''@|$(HAVE_DPRINTF)|g' \
- -e 's|@''REPLACE_DPRINTF''@|$(REPLACE_DPRINTF)|g' \
- -e 's|@''HAVE_VDPRINTF''@|$(HAVE_VDPRINTF)|g' \
- -e 's|@''REPLACE_VDPRINTF''@|$(REPLACE_VDPRINTF)|g' \
+ -e 's|@''HAVE_RENAMEAT''@|$(HAVE_RENAMEAT)|g' \
-e 's|@''HAVE_VASPRINTF''@|$(HAVE_VASPRINTF)|g' \
- -e 's|@''REPLACE_VASPRINTF''@|$(REPLACE_VASPRINTF)|g' \
- -e 's|@''HAVE_DECL_OBSTACK_PRINTF''@|$(HAVE_DECL_OBSTACK_PRINTF)|g' \
- -e 's|@''REPLACE_OBSTACK_PRINTF''@|$(REPLACE_OBSTACK_PRINTF)|g' \
+ -e 's|@''HAVE_VDPRINTF''@|$(HAVE_VDPRINTF)|g' \
+ -e 's|@''REPLACE_DPRINTF''@|$(REPLACE_DPRINTF)|g' \
+ -e 's|@''REPLACE_FCLOSE''@|$(REPLACE_FCLOSE)|g' \
+ -e 's|@''REPLACE_FFLUSH''@|$(REPLACE_FFLUSH)|g' \
-e 's|@''REPLACE_FOPEN''@|$(REPLACE_FOPEN)|g' \
+ -e 's|@''REPLACE_FPRINTF''@|$(REPLACE_FPRINTF)|g' \
+ -e 's|@''REPLACE_FPURGE''@|$(REPLACE_FPURGE)|g' \
-e 's|@''REPLACE_FREOPEN''@|$(REPLACE_FREOPEN)|g' \
- -e 's|@''REPLACE_FSEEKO''@|$(REPLACE_FSEEKO)|g' \
-e 's|@''REPLACE_FSEEK''@|$(REPLACE_FSEEK)|g' \
- -e 's|@''REPLACE_FTELLO''@|$(REPLACE_FTELLO)|g' \
+ -e 's|@''REPLACE_FSEEKO''@|$(REPLACE_FSEEKO)|g' \
-e 's|@''REPLACE_FTELL''@|$(REPLACE_FTELL)|g' \
- -e 's|@''REPLACE_FFLUSH''@|$(REPLACE_FFLUSH)|g' \
- -e 's|@''REPLACE_FPURGE''@|$(REPLACE_FPURGE)|g' \
- -e 's|@''HAVE_DECL_FPURGE''@|$(HAVE_DECL_FPURGE)|g' \
- -e 's|@''REPLACE_FCLOSE''@|$(REPLACE_FCLOSE)|g' \
- -e 's|@''HAVE_DECL_GETDELIM''@|$(HAVE_DECL_GETDELIM)|g' \
- -e 's|@''HAVE_DECL_GETLINE''@|$(HAVE_DECL_GETLINE)|g' \
+ -e 's|@''REPLACE_FTELLO''@|$(REPLACE_FTELLO)|g' \
-e 's|@''REPLACE_GETLINE''@|$(REPLACE_GETLINE)|g' \
+ -e 's|@''REPLACE_OBSTACK_PRINTF''@|$(REPLACE_OBSTACK_PRINTF)|g' \
-e 's|@''REPLACE_PERROR''@|$(REPLACE_PERROR)|g' \
+ -e 's|@''REPLACE_POPEN''@|$(REPLACE_POPEN)|g' \
+ -e 's|@''REPLACE_PRINTF''@|$(REPLACE_PRINTF)|g' \
+ -e 's|@''REPLACE_REMOVE''@|$(REPLACE_REMOVE)|g' \
+ -e 's|@''REPLACE_RENAME''@|$(REPLACE_RENAME)|g' \
+ -e 's|@''REPLACE_RENAMEAT''@|$(REPLACE_RENAMEAT)|g' \
+ -e 's|@''REPLACE_SNPRINTF''@|$(REPLACE_SNPRINTF)|g' \
+ -e 's|@''REPLACE_SPRINTF''@|$(REPLACE_SPRINTF)|g' \
+ -e 's|@''REPLACE_STDIO_WRITE_FUNCS''@|$(REPLACE_STDIO_WRITE_FUNCS)|g' \
+ -e 's|@''REPLACE_VASPRINTF''@|$(REPLACE_VASPRINTF)|g' \
+ -e 's|@''REPLACE_VDPRINTF''@|$(REPLACE_VDPRINTF)|g' \
+ -e 's|@''REPLACE_VFPRINTF''@|$(REPLACE_VFPRINTF)|g' \
+ -e 's|@''REPLACE_VPRINTF''@|$(REPLACE_VPRINTF)|g' \
+ -e 's|@''REPLACE_VSNPRINTF''@|$(REPLACE_VSNPRINTF)|g' \
+ -e 's|@''REPLACE_VSPRINTF''@|$(REPLACE_VSPRINTF)|g' \
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
< $(srcdir)/stdio.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += stdio.h stdio.h-t
# We need the following in order to create <stdlib.h> when the system
# doesn't have one that works with the given compiler.
stdlib.h: stdlib.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''NEXT_STDLIB_H''@|$(NEXT_STDLIB_H)|g' \
- -e 's|@''HAVE_RANDOM_H''@|$(HAVE_RANDOM_H)|g' \
- -e 's|@''GNULIB_MALLOC_POSIX''@|$(GNULIB_MALLOC_POSIX)|g' \
- -e 's|@''GNULIB_REALLOC_POSIX''@|$(GNULIB_REALLOC_POSIX)|g' \
- -e 's|@''GNULIB_CALLOC_POSIX''@|$(GNULIB_CALLOC_POSIX)|g' \
-e 's|@''GNULIB_ATOLL''@|$(GNULIB_ATOLL)|g' \
+ -e 's|@''GNULIB_CALLOC_POSIX''@|$(GNULIB_CALLOC_POSIX)|g' \
+ -e 's|@''GNULIB_CANONICALIZE_FILE_NAME''@|$(GNULIB_CANONICALIZE_FILE_NAME)|g' \
-e 's|@''GNULIB_GETLOADAVG''@|$(GNULIB_GETLOADAVG)|g' \
-e 's|@''GNULIB_GETSUBOPT''@|$(GNULIB_GETSUBOPT)|g' \
+ -e 's|@''GNULIB_MALLOC_POSIX''@|$(GNULIB_MALLOC_POSIX)|g' \
-e 's|@''GNULIB_MKDTEMP''@|$(GNULIB_MKDTEMP)|g' \
+ -e 's|@''GNULIB_MKOSTEMP''@|$(GNULIB_MKOSTEMP)|g' \
+ -e 's|@''GNULIB_MKOSTEMPS''@|$(GNULIB_MKOSTEMPS)|g' \
-e 's|@''GNULIB_MKSTEMP''@|$(GNULIB_MKSTEMP)|g' \
+ -e 's|@''GNULIB_MKSTEMPS''@|$(GNULIB_MKSTEMPS)|g' \
-e 's|@''GNULIB_PUTENV''@|$(GNULIB_PUTENV)|g' \
-e 's|@''GNULIB_RANDOM_R''@|$(GNULIB_RANDOM_R)|g' \
+ -e 's|@''GNULIB_REALLOC_POSIX''@|$(GNULIB_REALLOC_POSIX)|g' \
+ -e 's|@''GNULIB_REALPATH''@|$(GNULIB_REALPATH)|g' \
-e 's|@''GNULIB_RPMATCH''@|$(GNULIB_RPMATCH)|g' \
-e 's|@''GNULIB_SETENV''@|$(GNULIB_SETENV)|g' \
-e 's|@''GNULIB_STRTOD''@|$(GNULIB_STRTOD)|g' \
-e 's|@''GNULIB_UNSETENV''@|$(GNULIB_UNSETENV)|g' \
-e 's|@''HAVE_ATOLL''@|$(HAVE_ATOLL)|g' \
-e 's|@''HAVE_CALLOC_POSIX''@|$(HAVE_CALLOC_POSIX)|g' \
+ -e 's|@''HAVE_CANONICALIZE_FILE_NAME''@|$(HAVE_CANONICALIZE_FILE_NAME)|g' \
+ -e 's|@''HAVE_DECL_GETLOADAVG''@|$(HAVE_DECL_GETLOADAVG)|g' \
-e 's|@''HAVE_GETSUBOPT''@|$(HAVE_GETSUBOPT)|g' \
-e 's|@''HAVE_MALLOC_POSIX''@|$(HAVE_MALLOC_POSIX)|g' \
-e 's|@''HAVE_MKDTEMP''@|$(HAVE_MKDTEMP)|g' \
- -e 's|@''HAVE_REALLOC_POSIX''@|$(HAVE_REALLOC_POSIX)|g' \
+ -e 's|@''HAVE_MKOSTEMP''@|$(HAVE_MKOSTEMP)|g' \
+ -e 's|@''HAVE_MKOSTEMPS''@|$(HAVE_MKOSTEMPS)|g' \
+ -e 's|@''HAVE_MKSTEMPS''@|$(HAVE_MKSTEMPS)|g' \
+ -e 's|@''HAVE_RANDOM_H''@|$(HAVE_RANDOM_H)|g' \
-e 's|@''HAVE_RANDOM_R''@|$(HAVE_RANDOM_R)|g' \
+ -e 's|@''HAVE_REALLOC_POSIX''@|$(HAVE_REALLOC_POSIX)|g' \
+ -e 's|@''HAVE_REALPATH''@|$(HAVE_REALPATH)|g' \
-e 's|@''HAVE_RPMATCH''@|$(HAVE_RPMATCH)|g' \
-e 's|@''HAVE_SETENV''@|$(HAVE_SETENV)|g' \
-e 's|@''HAVE_STRTOD''@|$(HAVE_STRTOD)|g' \
-e 's|@''HAVE_STRUCT_RANDOM_DATA''@|$(HAVE_STRUCT_RANDOM_DATA)|g' \
-e 's|@''HAVE_SYS_LOADAVG_H''@|$(HAVE_SYS_LOADAVG_H)|g' \
-e 's|@''HAVE_UNSETENV''@|$(HAVE_UNSETENV)|g' \
- -e 's|@''HAVE_DECL_GETLOADAVG''@|$(HAVE_DECL_GETLOADAVG)|g' \
+ -e 's|@''REPLACE_CANONICALIZE_FILE_NAME''@|$(REPLACE_CANONICALIZE_FILE_NAME)|g' \
-e 's|@''REPLACE_MKSTEMP''@|$(REPLACE_MKSTEMP)|g' \
-e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \
+ -e 's|@''REPLACE_REALPATH''@|$(REPLACE_REALPATH)|g' \
+ -e 's|@''REPLACE_SETENV''@|$(REPLACE_SETENV)|g' \
-e 's|@''REPLACE_STRTOD''@|$(REPLACE_STRTOD)|g' \
- -e 's|@''VOID_UNSETENV''@|$(VOID_UNSETENV)|g' \
+ -e 's|@''REPLACE_UNSETENV''@|$(REPLACE_UNSETENV)|g' \
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
< $(srcdir)/stdlib.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += stdlib.h stdlib.h-t
# We need the following in order to create <string.h> when the system
# doesn't have one that works with the given compiler.
string.h: string.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''HAVE_STPNCPY''@|$(HAVE_STPNCPY)|g' \
-e 's|@''HAVE_STRCHRNUL''@|$(HAVE_STRCHRNUL)|g' \
-e 's|@''HAVE_DECL_STRDUP''@|$(HAVE_DECL_STRDUP)|g' \
- -e 's|@''HAVE_STRNDUP''@|$(HAVE_STRNDUP)|g' \
-e 's|@''HAVE_DECL_STRNDUP''@|$(HAVE_DECL_STRNDUP)|g' \
-e 's|@''HAVE_DECL_STRNLEN''@|$(HAVE_DECL_STRNLEN)|g' \
-e 's|@''HAVE_STRPBRK''@|$(HAVE_STRPBRK)|g' \
-e 's|@''REPLACE_STRDUP''@|$(REPLACE_STRDUP)|g' \
-e 's|@''REPLACE_STRSTR''@|$(REPLACE_STRSTR)|g' \
-e 's|@''REPLACE_STRERROR''@|$(REPLACE_STRERROR)|g' \
+ -e 's|@''REPLACE_STRNDUP''@|$(REPLACE_STRNDUP)|g' \
-e 's|@''REPLACE_STRSIGNAL''@|$(REPLACE_STRSIGNAL)|g' \
+ -e 's|@''REPLACE_STRTOK_R''@|$(REPLACE_STRTOK_R)|g' \
+ -e 's|@''UNDEFINE_STRTOK_R''@|$(UNDEFINE_STRTOK_R)|g' \
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
< $(srcdir)/string.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += string.h string.h-t
# We need the following in order to create <strings.h> when the system
# doesn't have one that works with the given compiler.
strings.h: strings.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''HAVE_DECL_STRNCASECMP''@|$(HAVE_DECL_STRNCASECMP)|g' \
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
< $(srcdir)/strings.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += strings.h strings.h-t
# We need the following in order to create <sys/file.h> when the system
# has one that is incomplete.
sys/file.h: sys_file.in.h
- @MKDIR_P@ sys
- rm -f $@-t $@
+ $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's/@''HAVE_SYS_FILE_H''@/$(HAVE_SYS_FILE_H)/g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's/@''HAVE_FLOCK''@/$(HAVE_FLOCK)/g' \
-e 's/@''GNULIB_FLOCK''@/$(GNULIB_FLOCK)/g' \
< $(srcdir)/sys_file.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += sys/file.h sys/file.h-t
MOSTLYCLEANDIRS += sys
## end gnulib module sys_file
+## begin gnulib module sys_socket
+
+BUILT_SOURCES += $(SYS_SOCKET_H)
+
+# We need the following in order to create <sys/socket.h> when the system
+# doesn't have one that works with the given compiler.
+sys/socket.h: sys_socket.in.h
+ $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_GEN)rm -f $@-t $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_SYS_SOCKET_H''@|$(NEXT_SYS_SOCKET_H)|g' \
+ -e 's|@''HAVE_SYS_SOCKET_H''@|$(HAVE_SYS_SOCKET_H)|g' \
+ -e 's|@''GNULIB_CLOSE''@|$(GNULIB_CLOSE)|g' \
+ -e 's|@''GNULIB_SOCKET''@|$(GNULIB_SOCKET)|g' \
+ -e 's|@''GNULIB_CONNECT''@|$(GNULIB_CONNECT)|g' \
+ -e 's|@''GNULIB_ACCEPT''@|$(GNULIB_ACCEPT)|g' \
+ -e 's|@''GNULIB_BIND''@|$(GNULIB_BIND)|g' \
+ -e 's|@''GNULIB_GETPEERNAME''@|$(GNULIB_GETPEERNAME)|g' \
+ -e 's|@''GNULIB_GETSOCKNAME''@|$(GNULIB_GETSOCKNAME)|g' \
+ -e 's|@''GNULIB_GETSOCKOPT''@|$(GNULIB_GETSOCKOPT)|g' \
+ -e 's|@''GNULIB_LISTEN''@|$(GNULIB_LISTEN)|g' \
+ -e 's|@''GNULIB_RECV''@|$(GNULIB_RECV)|g' \
+ -e 's|@''GNULIB_SEND''@|$(GNULIB_SEND)|g' \
+ -e 's|@''GNULIB_RECVFROM''@|$(GNULIB_RECVFROM)|g' \
+ -e 's|@''GNULIB_SENDTO''@|$(GNULIB_SENDTO)|g' \
+ -e 's|@''GNULIB_SETSOCKOPT''@|$(GNULIB_SETSOCKOPT)|g' \
+ -e 's|@''GNULIB_SHUTDOWN''@|$(GNULIB_SHUTDOWN)|g' \
+ -e 's|@''GNULIB_ACCEPT4''@|$(GNULIB_ACCEPT4)|g' \
+ -e 's|@''HAVE_WINSOCK2_H''@|$(HAVE_WINSOCK2_H)|g' \
+ -e 's|@''HAVE_WS2TCPIP_H''@|$(HAVE_WS2TCPIP_H)|g' \
+ -e 's|@''HAVE_STRUCT_SOCKADDR_STORAGE''@|$(HAVE_STRUCT_SOCKADDR_STORAGE)|g' \
+ -e 's|@''HAVE_SA_FAMILY_T''@|$(HAVE_SA_FAMILY_T)|g' \
+ -e 's|@''HAVE_ACCEPT4''@|$(HAVE_ACCEPT4)|g' \
+ -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ < $(srcdir)/sys_socket.in.h; \
+ } > $@-t && \
+ mv -f $@-t $@
+MOSTLYCLEANFILES += sys/socket.h sys/socket.h-t
+MOSTLYCLEANDIRS += sys
+
+EXTRA_DIST += sys_socket.in.h
+
+## end gnulib module sys_socket
+
+## begin gnulib module sys_stat
+
+BUILT_SOURCES += sys/stat.h
+
+# We need the following in order to create <sys/stat.h> when the system
+# has one that is incomplete.
+sys/stat.h: sys_stat.in.h
+ $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_GEN)rm -f $@-t $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_SYS_STAT_H''@|$(NEXT_SYS_STAT_H)|g' \
+ -e 's|@''GNULIB_FCHMODAT''@|$(GNULIB_FCHMODAT)|g' \
+ -e 's|@''GNULIB_FSTATAT''@|$(GNULIB_FSTATAT)|g' \
+ -e 's|@''GNULIB_FUTIMENS''@|$(GNULIB_FUTIMENS)|g' \
+ -e 's|@''GNULIB_LCHMOD''@|$(GNULIB_LCHMOD)|g' \
+ -e 's|@''GNULIB_LSTAT''@|$(GNULIB_LSTAT)|g' \
+ -e 's|@''GNULIB_MKDIRAT''@|$(GNULIB_MKDIRAT)|g' \
+ -e 's|@''GNULIB_MKFIFO''@|$(GNULIB_MKFIFO)|g' \
+ -e 's|@''GNULIB_MKFIFOAT''@|$(GNULIB_MKFIFOAT)|g' \
+ -e 's|@''GNULIB_MKNOD''@|$(GNULIB_MKNOD)|g' \
+ -e 's|@''GNULIB_MKNODAT''@|$(GNULIB_MKNODAT)|g' \
+ -e 's|@''GNULIB_STAT''@|$(GNULIB_STAT)|g' \
+ -e 's|@''GNULIB_UTIMENSAT''@|$(GNULIB_UTIMENSAT)|g' \
+ -e 's|@''HAVE_FCHMODAT''@|$(HAVE_FCHMODAT)|g' \
+ -e 's|@''HAVE_FSTATAT''@|$(HAVE_FSTATAT)|g' \
+ -e 's|@''HAVE_FUTIMENS''@|$(HAVE_FUTIMENS)|g' \
+ -e 's|@''HAVE_LCHMOD''@|$(HAVE_LCHMOD)|g' \
+ -e 's|@''HAVE_LSTAT''@|$(HAVE_LSTAT)|g' \
+ -e 's|@''HAVE_MKDIRAT''@|$(HAVE_MKDIRAT)|g' \
+ -e 's|@''HAVE_MKFIFO''@|$(HAVE_MKFIFO)|g' \
+ -e 's|@''HAVE_MKFIFOAT''@|$(HAVE_MKFIFOAT)|g' \
+ -e 's|@''HAVE_MKNOD''@|$(HAVE_MKNOD)|g' \
+ -e 's|@''HAVE_MKNODAT''@|$(HAVE_MKNODAT)|g' \
+ -e 's|@''HAVE_UTIMENSAT''@|$(HAVE_UTIMENSAT)|g' \
+ -e 's|@''REPLACE_FSTAT''@|$(REPLACE_FSTAT)|g' \
+ -e 's|@''REPLACE_FSTATAT''@|$(REPLACE_FSTATAT)|g' \
+ -e 's|@''REPLACE_FUTIMENS''@|$(REPLACE_FUTIMENS)|g' \
+ -e 's|@''REPLACE_LSTAT''@|$(REPLACE_LSTAT)|g' \
+ -e 's|@''REPLACE_MKDIR''@|$(REPLACE_MKDIR)|g' \
+ -e 's|@''REPLACE_MKFIFO''@|$(REPLACE_MKFIFO)|g' \
+ -e 's|@''REPLACE_MKNOD''@|$(REPLACE_MKNOD)|g' \
+ -e 's|@''REPLACE_STAT''@|$(REPLACE_STAT)|g' \
+ -e 's|@''REPLACE_UTIMENSAT''@|$(REPLACE_UTIMENSAT)|g' \
+ -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ < $(srcdir)/sys_stat.in.h; \
+ } > $@-t && \
+ mv $@-t $@
+MOSTLYCLEANFILES += sys/stat.h sys/stat.h-t
+MOSTLYCLEANDIRS += sys
+
+EXTRA_DIST += sys_stat.in.h
+
+## end gnulib module sys_stat
+
## begin gnulib module time
BUILT_SOURCES += time.h
# We need the following in order to create <time.h> when the system
# doesn't have one that works with the given compiler.
time.h: time.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \
-e 's|@TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \
< $(srcdir)/time.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += time.h time.h-t
# We need the following in order to create an empty placeholder for
# <unistd.h> when the system doesn't have one.
unistd.h: unistd.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''HAVE_UNISTD_H''@|$(HAVE_UNISTD_H)|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''GNULIB_CHOWN''@|$(GNULIB_CHOWN)|g' \
-e 's|@''GNULIB_CLOSE''@|$(GNULIB_CLOSE)|g' \
-e 's|@''GNULIB_DUP2''@|$(GNULIB_DUP2)|g' \
+ -e 's|@''GNULIB_DUP3''@|$(GNULIB_DUP3)|g' \
-e 's|@''GNULIB_ENVIRON''@|$(GNULIB_ENVIRON)|g' \
-e 's|@''GNULIB_EUIDACCESS''@|$(GNULIB_EUIDACCESS)|g' \
+ -e 's|@''GNULIB_FACCESSAT''@|$(GNULIB_FACCESSAT)|g' \
-e 's|@''GNULIB_FCHDIR''@|$(GNULIB_FCHDIR)|g' \
+ -e 's|@''GNULIB_FCHOWNAT''@|$(GNULIB_FCHOWNAT)|g' \
-e 's|@''GNULIB_FSYNC''@|$(GNULIB_FSYNC)|g' \
-e 's|@''GNULIB_FTRUNCATE''@|$(GNULIB_FTRUNCATE)|g' \
-e 's|@''GNULIB_GETCWD''@|$(GNULIB_GETCWD)|g' \
-e 's|@''GNULIB_GETDOMAINNAME''@|$(GNULIB_GETDOMAINNAME)|g' \
-e 's|@''GNULIB_GETDTABLESIZE''@|$(GNULIB_GETDTABLESIZE)|g' \
+ -e 's|@''GNULIB_GETGROUPS''@|$(GNULIB_GETGROUPS)|g' \
-e 's|@''GNULIB_GETHOSTNAME''@|$(GNULIB_GETHOSTNAME)|g' \
-e 's|@''GNULIB_GETLOGIN_R''@|$(GNULIB_GETLOGIN_R)|g' \
-e 's|@''GNULIB_GETPAGESIZE''@|$(GNULIB_GETPAGESIZE)|g' \
-e 's|@''GNULIB_GETUSERSHELL''@|$(GNULIB_GETUSERSHELL)|g' \
-e 's|@''GNULIB_LCHOWN''@|$(GNULIB_LCHOWN)|g' \
-e 's|@''GNULIB_LINK''@|$(GNULIB_LINK)|g' \
+ -e 's|@''GNULIB_LINKAT''@|$(GNULIB_LINKAT)|g' \
-e 's|@''GNULIB_LSEEK''@|$(GNULIB_LSEEK)|g' \
+ -e 's|@''GNULIB_PIPE2''@|$(GNULIB_PIPE2)|g' \
-e 's|@''GNULIB_READLINK''@|$(GNULIB_READLINK)|g' \
+ -e 's|@''GNULIB_READLINKAT''@|$(GNULIB_READLINKAT)|g' \
+ -e 's|@''GNULIB_RMDIR''@|$(GNULIB_RMDIR)|g' \
-e 's|@''GNULIB_SLEEP''@|$(GNULIB_SLEEP)|g' \
+ -e 's|@''GNULIB_SYMLINK''@|$(GNULIB_SYMLINK)|g' \
+ -e 's|@''GNULIB_SYMLINKAT''@|$(GNULIB_SYMLINKAT)|g' \
+ -e 's|@''GNULIB_UNISTD_H_GETOPT''@|$(GNULIB_UNISTD_H_GETOPT)|g' \
-e 's|@''GNULIB_UNISTD_H_SIGPIPE''@|$(GNULIB_UNISTD_H_SIGPIPE)|g' \
+ -e 's|@''GNULIB_UNLINK''@|$(GNULIB_UNLINK)|g' \
+ -e 's|@''GNULIB_UNLINKAT''@|$(GNULIB_UNLINKAT)|g' \
+ -e 's|@''GNULIB_USLEEP''@|$(GNULIB_USLEEP)|g' \
-e 's|@''GNULIB_WRITE''@|$(GNULIB_WRITE)|g' \
+ -e 's|@''HAVE_CHOWN''@|$(HAVE_CHOWN)|g' \
-e 's|@''HAVE_DUP2''@|$(HAVE_DUP2)|g' \
+ -e 's|@''HAVE_DUP3''@|$(HAVE_DUP3)|g' \
-e 's|@''HAVE_EUIDACCESS''@|$(HAVE_EUIDACCESS)|g' \
+ -e 's|@''HAVE_FACCESSAT''@|$(HAVE_FACCESSAT)|g' \
+ -e 's|@''HAVE_FCHOWNAT''@|$(HAVE_FCHOWNAT)|g' \
-e 's|@''HAVE_FSYNC''@|$(HAVE_FSYNC)|g' \
-e 's|@''HAVE_FTRUNCATE''@|$(HAVE_FTRUNCATE)|g' \
-e 's|@''HAVE_GETDOMAINNAME''@|$(HAVE_GETDOMAINNAME)|g' \
-e 's|@''HAVE_GETDTABLESIZE''@|$(HAVE_GETDTABLESIZE)|g' \
+ -e 's|@''HAVE_GETGROUPS''@|$(HAVE_GETGROUPS)|g' \
-e 's|@''HAVE_GETHOSTNAME''@|$(HAVE_GETHOSTNAME)|g' \
-e 's|@''HAVE_GETPAGESIZE''@|$(HAVE_GETPAGESIZE)|g' \
-e 's|@''HAVE_GETUSERSHELL''@|$(HAVE_GETUSERSHELL)|g' \
+ -e 's|@''HAVE_LCHOWN''@|$(HAVE_LCHOWN)|g' \
-e 's|@''HAVE_LINK''@|$(HAVE_LINK)|g' \
+ -e 's|@''HAVE_LINKAT''@|$(HAVE_LINKAT)|g' \
+ -e 's|@''HAVE_PIPE2''@|$(HAVE_PIPE2)|g' \
-e 's|@''HAVE_READLINK''@|$(HAVE_READLINK)|g' \
+ -e 's|@''HAVE_READLINKAT''@|$(HAVE_READLINKAT)|g' \
-e 's|@''HAVE_SLEEP''@|$(HAVE_SLEEP)|g' \
+ -e 's|@''HAVE_SYMLINK''@|$(HAVE_SYMLINK)|g' \
+ -e 's|@''HAVE_SYMLINKAT''@|$(HAVE_SYMLINKAT)|g' \
+ -e 's|@''HAVE_UNLINKAT''@|$(HAVE_UNLINKAT)|g' \
+ -e 's|@''HAVE_USLEEP''@|$(HAVE_USLEEP)|g' \
-e 's|@''HAVE_DECL_ENVIRON''@|$(HAVE_DECL_ENVIRON)|g' \
-e 's|@''HAVE_DECL_GETLOGIN_R''@|$(HAVE_DECL_GETLOGIN_R)|g' \
-e 's|@''HAVE_OS_H''@|$(HAVE_OS_H)|g' \
-e 's|@''HAVE_SYS_PARAM_H''@|$(HAVE_SYS_PARAM_H)|g' \
-e 's|@''REPLACE_CHOWN''@|$(REPLACE_CHOWN)|g' \
-e 's|@''REPLACE_CLOSE''@|$(REPLACE_CLOSE)|g' \
+ -e 's|@''REPLACE_DUP''@|$(REPLACE_DUP)|g' \
-e 's|@''REPLACE_DUP2''@|$(REPLACE_DUP2)|g' \
-e 's|@''REPLACE_FCHDIR''@|$(REPLACE_FCHDIR)|g' \
+ -e 's|@''REPLACE_FCHOWNAT''@|$(REPLACE_FCHOWNAT)|g' \
-e 's|@''REPLACE_GETCWD''@|$(REPLACE_GETCWD)|g' \
+ -e 's|@''REPLACE_GETGROUPS''@|$(REPLACE_GETGROUPS)|g' \
-e 's|@''REPLACE_GETPAGESIZE''@|$(REPLACE_GETPAGESIZE)|g' \
-e 's|@''REPLACE_LCHOWN''@|$(REPLACE_LCHOWN)|g' \
+ -e 's|@''REPLACE_LINK''@|$(REPLACE_LINK)|g' \
+ -e 's|@''REPLACE_LINKAT''@|$(REPLACE_LINKAT)|g' \
-e 's|@''REPLACE_LSEEK''@|$(REPLACE_LSEEK)|g' \
+ -e 's|@''REPLACE_READLINK''@|$(REPLACE_READLINK)|g' \
+ -e 's|@''REPLACE_RMDIR''@|$(REPLACE_RMDIR)|g' \
+ -e 's|@''REPLACE_SLEEP''@|$(REPLACE_SLEEP)|g' \
+ -e 's|@''REPLACE_SYMLINK''@|$(REPLACE_SYMLINK)|g' \
+ -e 's|@''REPLACE_UNLINK''@|$(REPLACE_UNLINK)|g' \
+ -e 's|@''REPLACE_UNLINKAT''@|$(REPLACE_UNLINKAT)|g' \
+ -e 's|@''REPLACE_USLEEP''@|$(REPLACE_USLEEP)|g' \
-e 's|@''REPLACE_WRITE''@|$(REPLACE_WRITE)|g' \
-e 's|@''UNISTD_H_HAVE_WINSOCK2_H''@|$(UNISTD_H_HAVE_WINSOCK2_H)|g' \
+ -e 's|@''UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS''@|$(UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS)|g' \
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
< $(srcdir)/unistd.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += unistd.h unistd.h-t
## end gnulib module unitypes
+## begin gnulib module useless-if-before-free
+
+
+EXTRA_DIST += $(top_srcdir)/build-aux/useless-if-before-free
+
+## end gnulib module useless-if-before-free
+
## begin gnulib module vasnprintf
## end gnulib module vasnprintf
+## begin gnulib module vc-list-files
+
+
+EXTRA_DIST += $(top_srcdir)/build-aux/vc-list-files
+
+## end gnulib module vc-list-files
+
## begin gnulib module verify
libgnu_la_SOURCES += verify.h
## end gnulib module verify
+## begin gnulib module version-etc
+
+libgnu_la_SOURCES += version-etc.h version-etc.c
+
+## end gnulib module version-etc
+
+## begin gnulib module version-etc-fsf
+
+libgnu_la_SOURCES += version-etc-fsf.c
+
+## end gnulib module version-etc-fsf
+
## begin gnulib module vsnprintf
# We need the following in order to create <wchar.h> when the system
# version does not work standalone.
wchar.h: wchar.in.h
- rm -f $@-t $@
+ $(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''REPLACE_WCWIDTH''@|$(REPLACE_WCWIDTH)|g' \
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
< $(srcdir)/wchar.in.h; \
- } > $@-t
+ } > $@-t && \
mv $@-t $@
MOSTLYCLEANFILES += wchar.h wchar.h-t
--- /dev/null
+/* Determine alignment of types.
+ Copyright (C) 2003-2004, 2006, 2009 Free Software Foundation, Inc.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef _ALIGNOF_H
+#define _ALIGNOF_H
+
+#include <stddef.h>
+
+/* Determine the alignment of a structure slot (field) of a given type,
+ at compile time. Note that the result depends on the ABI.
+ Note: The result cannot be used as a value for an 'enum' constant,
+ due to bugs in HP-UX 10.20 cc and AIX 3.2.5 xlc. */
+#if defined __cplusplus
+ template <class type> struct alignof_helper { char __slot1; type __slot2; };
+# define alignof_slot(type) offsetof (alignof_helper<type>, __slot2)
+#else
+# define alignof_slot(type) offsetof (struct { char __slot1; type __slot2; }, __slot2)
+#endif
+
+/* Determine the good alignment of a object of the given type at compile time.
+ Note that this is not necessarily the same as alignof_slot(type).
+ For example, with GNU C on x86 platforms: alignof_type(double) = 8, but
+ - when -malign-double is not specified: alignof_slot(double) = 4,
+ - when -malign-double is specified: alignof_slot(double) = 8.
+ Note: The result cannot be used as a value for an 'enum' constant,
+ due to bugs in HP-UX 10.20 cc and AIX 3.2.5 xlc. */
+#if defined __GNUC__
+# define alignof_type __alignof__
+#else
+# define alignof_type alignof_slot
+#endif
+
+/* alignof is an alias for alignof_slot semantics, since that's what most
+ callers need.
+ Note: The result cannot be used as a value for an 'enum' constant,
+ due to bugs in HP-UX 10.20 cc and AIX 3.2.5 xlc. */
+#define alignof alignof_slot
+
+#endif /* _ALIGNOF_H */
--- /dev/null
+/* A GNU-like <arpa/inet.h>.
+
+ Copyright (C) 2005-2006, 2008 Free Software Foundation, Inc.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef _GL_ARPA_INET_H
+
+/* Gnulib's sys/socket.h is responsible for pulling in winsock2.h etc
+ under MinGW. */
+#include <sys/socket.h>
+
+#if @HAVE_ARPA_INET_H@
+
+# if __GNUC__ >= 3
+@PRAGMA_SYSTEM_HEADER@
+# endif
+
+/* The include_next requires a split double-inclusion guard. */
+# @INCLUDE_NEXT@ @NEXT_ARPA_INET_H@
+
+#endif
+
+#ifndef _GL_ARPA_INET_H
+#define _GL_ARPA_INET_H
+
+/* The definition of GL_LINK_WARNING is copied here. */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#if @GNULIB_INET_NTOP@
+# if !@HAVE_DECL_INET_NTOP@
+/* Converts an internet address from internal format to a printable,
+ presentable format.
+ AF is an internet address family, such as AF_INET or AF_INET6.
+ SRC points to a 'struct in_addr' (for AF_INET) or 'struct in6_addr'
+ (for AF_INET6).
+ DST points to a buffer having room for CNT bytes.
+ The printable representation of the address (in numeric form, not
+ surrounded by [...], no reverse DNS is done) is placed in DST, and
+ DST is returned. If an error occurs, the return value is NULL and
+ errno is set. If CNT bytes are not sufficient to hold the result,
+ the return value is NULL and errno is set to ENOSPC. A good value
+ for CNT is 46.
+
+ For more details, see the POSIX:2001 specification
+ <http://www.opengroup.org/susv3xsh/inet_ntop.html>. */
+extern const char *inet_ntop (int af, const void *restrict src,
+ char *restrict dst, socklen_t cnt);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef inet_ntop
+# define inet_ntop(af,src,dst,cnt) \
+ (GL_LINK_WARNING ("inet_ntop is unportable - " \
+ "use gnulib module inet_ntop for portability"), \
+ inet_ntop (af, src, dst, cnt))
+#endif
+
+#if @GNULIB_INET_PTON@
+# if !@HAVE_DECL_INET_PTON@
+extern int inet_pton (int af, const char *restrict src, void *restrict dst);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef inet_pton
+# define inet_pton(af,src,dst) \
+ (GL_LINK_WARNING ("inet_pton is unportable - " \
+ "use gnulib module inet_pton for portability"), \
+ inet_pton (af, src, dst))
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _GL_ARPA_INET_H */
+#endif /* _GL_ARPA_INET_H */
/* Return the canonical absolute name of a given file.
- Copyright (C) 1996-2003, 2005-2008 Free Software Foundation, Inc.
+ Copyright (C) 1996-2009 Free Software Foundation, Inc.
This file is part of the GNU C Library.
This program is free software: you can redistribute it and/or modify
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. */
-#include <config.h>
-
-/* Avoid a clash of our rpl_realpath() function with the prototype in
- <stdlib.h> on Solaris 2.5.1. */
-#undef realpath
-
-#if !HAVE_CANONICALIZE_FILE_NAME || defined _LIBC
+#ifndef _LIBC
+# include <config.h>
+#endif
-#include <alloca.h>
+#if !HAVE_CANONICALIZE_FILE_NAME || !FUNC_REALPATH_WORKS || defined _LIBC
/* Specification. */
-#include "canonicalize.h"
-
-#include <stddef.h>
#include <stdlib.h>
-#include <string.h>
-
-#if HAVE_UNISTD_H || defined _LIBC
-# include <unistd.h>
-#endif
+#include <alloca.h>
+#include <string.h>
+#include <unistd.h>
#include <limits.h>
-
#if HAVE_SYS_PARAM_H || defined _LIBC
# include <sys/param.h>
#endif
-#ifndef MAXSYMLINKS
-# define MAXSYMLINKS 20
-#endif
-
#include <sys/stat.h>
-
#include <errno.h>
-#ifndef _LIBC
-# define __set_errno(e) errno = (e)
-# ifndef ENAMETOOLONG
-# define ENAMETOOLONG EINVAL
-# endif
-#endif
+#include <stddef.h>
#ifdef _LIBC
# include <shlib-compat.h>
# define compat_symbol(lib, local, symbol, version)
# define weak_alias(local, symbol)
# define __canonicalize_file_name canonicalize_file_name
-# define __realpath rpl_realpath
+# define __realpath realpath
# include "pathmax.h"
# include "malloca.h"
# if HAVE_GETCWD
# define __getcwd(buf, max) getwd (buf)
# endif
# define __readlink readlink
- /* On systems without symbolic links, call stat() instead of lstat(). */
-# if !defined S_ISLNK && !HAVE_READLINK
-# define lstat stat
+# define __set_errno(e) errno = (e)
+# ifndef MAXSYMLINKS
+# ifdef SYMLOOP_MAX
+# define MAXSYMLINKS SYMLOOP_MAX
+# else
+# define MAXSYMLINKS 20
+# endif
# endif
#endif
+#ifndef DOUBLE_SLASH_IS_DISTINCT_ROOT
+# define DOUBLE_SLASH_IS_DISTINCT_ROOT 0
+#endif
+
+#if !FUNC_REALPATH_WORKS || defined _LIBC
/* Return the canonical absolute name of file NAME. A canonical name
does not contain any `.', `..' components nor any repeated path
separators ('/') or symlinks. All path components must exist. If
char *rpath, *dest, *extra_buf = NULL;
const char *start, *end, *rpath_limit;
long int path_max;
-#if HAVE_READLINK
int num_links = 0;
-#endif
if (name == NULL)
{
{
rpath[0] = '/';
dest = rpath + 1;
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT && name[1] == '/')
+ *dest++ = '/';
}
for (start = end = name; *start; start = end)
#else
struct stat st;
#endif
+ int n;
/* Skip sequence of multiple path-separators. */
while (*start == '/')
/* Back up to previous component, ignore if at root already. */
if (dest > rpath + 1)
while ((--dest)[-1] != '/');
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1
+ && *dest == '/')
+ dest++;
}
else
{
#endif
goto error;
-#if HAVE_READLINK
if (S_ISLNK (st.st_mode))
{
char *buf;
size_t len;
- int n;
if (++num_links > MAXSYMLINKS)
{
name = end = memcpy (extra_buf, buf, n);
if (buf[0] == '/')
- dest = rpath + 1; /* It's an absolute symlink */
+ {
+ dest = rpath + 1; /* It's an absolute symlink */
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT && buf[1] == '/')
+ *dest++ = '/';
+ }
else
- /* Back up to previous component, ignore if at root already: */
- if (dest > rpath + 1)
- while ((--dest)[-1] != '/');
+ {
+ /* Back up to previous component, ignore if at root
+ already: */
+ if (dest > rpath + 1)
+ while ((--dest)[-1] != '/');
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1
+ && *dest == '/')
+ dest++;
+ }
+ }
+ else if (!S_ISDIR (st.st_mode) && *end != '\0')
+ {
+ __set_errno (ENOTDIR);
+ goto error;
}
-#endif
}
}
if (dest > rpath + 1 && dest[-1] == '/')
--dest;
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1 && *dest == '/')
+ dest++;
*dest = '\0';
if (extra_buf)
freea (extra_buf);
- return resolved ? memcpy (resolved, rpath, dest - rpath + 1) : rpath;
+ return rpath;
error:
{
int saved_errno = errno;
if (extra_buf)
freea (extra_buf);
- if (resolved)
- strcpy (resolved, rpath);
- else
+ if (resolved == NULL)
free (rpath);
errno = saved_errno;
}
return NULL;
}
-#ifdef _LIBC
versioned_symbol (libc, __realpath, realpath, GLIBC_2_3);
-#endif
+#endif /* !FUNC_REALPATH_WORKS || defined _LIBC */
#if SHLIB_COMPAT(libc, GLIBC_2_0, GLIBC_2_3)
char *
+attribute_compat_text_section
__old_realpath (const char *name, char *resolved)
{
if (resolved == NULL)
+++ /dev/null
-/* Return the canonical absolute name of a given file.
- Copyright (C) 1996-2007 Free Software Foundation, Inc.
-
- This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
-
-#ifndef CANONICALIZE_H_
-# define CANONICALIZE_H_
-
-# if GNULIB_CANONICALIZE
-enum canonicalize_mode_t
- {
- /* All components must exist. */
- CAN_EXISTING = 0,
-
- /* All components excluding last one must exist. */
- CAN_ALL_BUT_LAST = 1,
-
- /* No requirements on components existence. */
- CAN_MISSING = 2
- };
-typedef enum canonicalize_mode_t canonicalize_mode_t;
-
-/* Return a malloc'd string containing the canonical absolute name of
- the named file. This acts like canonicalize_file_name, except that
- whether components must exist depends on the canonicalize_mode_t
- argument. */
-char *canonicalize_filename_mode (const char *, canonicalize_mode_t);
-# endif
-
-# if HAVE_DECL_CANONICALIZE_FILE_NAME
-# include <stdlib.h>
-# else
-/* Return a malloc'd string containing the canonical absolute name of
- the named file. If any file name component does not exist or is a
- symlink to a nonexistent file, return NULL. A canonical name does
- not contain any `.', `..' components nor any repeated file name
- separators ('/') or symlinks. */
-char *canonicalize_file_name (const char *);
-# endif
-
-#endif /* !CANONICALIZE_H_ */
+++ /dev/null
-/* count-one-bits.h -- counts the number of 1-bits in a word.
- Copyright (C) 2007-2008 Free Software Foundation, Inc.
-
- This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
-
-/* Written by Ben Pfaff. */
-
-#ifndef COUNT_ONE_BITS_H
-# define COUNT_ONE_BITS_H 1
-
-#include <stdlib.h>
-#include "verify.h"
-
-/* Expand the code which computes the number of 1-bits of the local
- variable 'x' of type TYPE (an unsigned integer type) and returns it
- from the current function. */
-#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)
-#define COUNT_ONE_BITS(BUILTIN, TYPE) \
- return BUILTIN (x);
-#else
-#define COUNT_ONE_BITS(BUILTIN, TYPE) \
- /* This condition is written so as to avoid shifting by more than \
- 31 bits at once, and also avoids a random HP-UX cc bug. */ \
- verify (((TYPE) -1 >> 31 >> 31 >> 2) == 0); /* TYPE has at most 64 bits */ \
- int count = count_one_bits_32 (x); \
- if (1 < (TYPE) -1 >> 31) /* TYPE has more than 32 bits? */ \
- count += count_one_bits_32 (x >> 31 >> 1); \
- return count;
-
-/* Compute and return the the number of 1-bits set in the least
- significant 32 bits of X. */
-static inline int
-count_one_bits_32 (unsigned int x)
-{
- x = ((x & 0xaaaaaaaaU) >> 1) + (x & 0x55555555U);
- x = ((x & 0xccccccccU) >> 2) + (x & 0x33333333U);
- x = (x >> 16) + (x & 0xffff);
- x = ((x & 0xf0f0) >> 4) + (x & 0x0f0f);
- return (x >> 8) + (x & 0x00ff);
-}
-#endif
-
-/* Compute and return the number of 1-bits set in X. */
-static inline int
-count_one_bits (unsigned int x)
-{
- COUNT_ONE_BITS (__builtin_popcount, unsigned int);
-}
-
-/* Compute and return the number of 1-bits set in X. */
-static inline int
-count_one_bits_l (unsigned long int x)
-{
- COUNT_ONE_BITS (__builtin_popcountl, unsigned long int);
-}
-
-#if HAVE_UNSIGNED_LONG_LONG_INT
-/* Compute and return the number of 1-bits set in X. */
-static inline int
-count_one_bits_ll (unsigned long long int x)
-{
- COUNT_ONE_BITS (__builtin_popcountll, unsigned long long int);
-}
-#endif
-
-#endif /* COUNT_ONE_BITS_H */
--- /dev/null
+/* Duplicate a locale object.
+ Copyright (C) 2009 Free Software Foundation, Inc.
+
+ This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Bruno Haible <bruno@clisp.org>, 2007. */
+
+#include <config.h>
+
+/* Specification. */
+#include <locale.h>
+
+#include <errno.h>
+#include <string.h>
+
+#define SIZEOF(a) (sizeof(a) / sizeof(a[0]))
+
+#undef duplocale
+
+locale_t
+rpl_duplocale (locale_t locale)
+{
+ /* Work around crash in the duplocale function in glibc < 2.12.
+ See <http://sourceware.org/bugzilla/show_bug.cgi?id=10969>. */
+ if (locale == LC_GLOBAL_LOCALE)
+ {
+ /* Create a copy of the locale by fetching the name of each locale
+ category, starting with LC_CTYPE. */
+ static struct { int cat; int mask; } categories[] =
+ {
+ { LC_NUMERIC, LC_NUMERIC_MASK },
+ { LC_TIME, LC_TIME_MASK },
+ { LC_COLLATE, LC_COLLATE_MASK },
+ { LC_MONETARY, LC_MONETARY_MASK },
+ { LC_MESSAGES, LC_MESSAGES_MASK }
+#ifdef LC_PAPER
+ , { LC_PAPER, LC_PAPER_MASK }
+#endif
+#ifdef LC_NAME
+ , { LC_NAME, LC_NAME_MASK }
+#endif
+#ifdef LC_ADDRESS
+ , { LC_ADDRESS, LC_ADDRESS_MASK }
+#endif
+#ifdef LC_TELEPHONE
+ , { LC_TELEPHONE, LC_TELEPHONE_MASK }
+#endif
+#ifdef LC_MEASUREMENT
+ , { LC_MEASUREMENT, LC_MEASUREMENT_MASK }
+#endif
+#ifdef LC_IDENTIFICATION
+ , { LC_IDENTIFICATION, LC_IDENTIFICATION_MASK }
+#endif
+ };
+ const char *base_name;
+ locale_t base_copy;
+ unsigned int i;
+
+ base_name = setlocale (LC_CTYPE, NULL);
+ base_copy = newlocale (LC_ALL_MASK, base_name, NULL);
+ if (base_copy == NULL)
+ return NULL;
+
+ for (i = 0; i < SIZEOF (categories); i++)
+ {
+ int category = categories[i].cat;
+ int category_mask = categories[i].mask;
+ const char *name = setlocale (category, NULL);
+ if (strcmp (name, base_name) != 0)
+ {
+ locale_t copy = newlocale (category_mask, name, base_copy);
+ if (copy == NULL)
+ {
+ int saved_errno = errno;
+ freelocale (base_copy);
+ errno = saved_errno;
+ return NULL;
+ }
+ /* No need to call freelocale (base_copy) if copy != base_copy;
+ the newlocale function already takes care of doing it. */
+ base_copy = copy;
+ }
+ }
+
+ return base_copy;
+ }
+
+ return duplocale (locale);
+}
--- /dev/null
+/* Convenience header for conditional use of GNU <libintl.h>.
+ Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009 Free Software Foundation, Inc.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef _LIBGETTEXT_H
+#define _LIBGETTEXT_H 1
+
+/* NLS can be disabled through the configure --disable-nls option. */
+#if ENABLE_NLS
+
+/* Get declarations of GNU message catalog functions. */
+# include <libintl.h>
+
+/* You can set the DEFAULT_TEXT_DOMAIN macro to specify the domain used by
+ the gettext() and ngettext() macros. This is an alternative to calling
+ textdomain(), and is useful for libraries. */
+# ifdef DEFAULT_TEXT_DOMAIN
+# undef gettext
+# define gettext(Msgid) \
+ dgettext (DEFAULT_TEXT_DOMAIN, Msgid)
+# undef ngettext
+# define ngettext(Msgid1, Msgid2, N) \
+ dngettext (DEFAULT_TEXT_DOMAIN, Msgid1, Msgid2, N)
+# endif
+
+#else
+
+/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which
+ chokes if dcgettext is defined as a macro. So include it now, to make
+ later inclusions of <locale.h> a NOP. We don't include <libintl.h>
+ as well because people using "gettext.h" will not include <libintl.h>,
+ and also including <libintl.h> would fail on SunOS 4, whereas <locale.h>
+ is OK. */
+#if defined(__sun)
+# include <locale.h>
+#endif
+
+/* Many header files from the libstdc++ coming with g++ 3.3 or newer include
+ <libintl.h>, which chokes if dcgettext is defined as a macro. So include
+ it now, to make later inclusions of <libintl.h> a NOP. */
+#if defined(__cplusplus) && defined(__GNUG__) && (__GNUC__ >= 3)
+# include <cstdlib>
+# if (__GLIBC__ >= 2) || _GLIBCXX_HAVE_LIBINTL_H
+# include <libintl.h>
+# endif
+#endif
+
+/* Disabled NLS.
+ The casts to 'const char *' serve the purpose of producing warnings
+ for invalid uses of the value returned from these functions.
+ On pre-ANSI systems without 'const', the config.h file is supposed to
+ contain "#define const". */
+# undef gettext
+# define gettext(Msgid) ((const char *) (Msgid))
+# undef dgettext
+# define dgettext(Domainname, Msgid) ((void) (Domainname), gettext (Msgid))
+# undef dcgettext
+# define dcgettext(Domainname, Msgid, Category) \
+ ((void) (Category), dgettext (Domainname, Msgid))
+# undef ngettext
+# define ngettext(Msgid1, Msgid2, N) \
+ ((N) == 1 \
+ ? ((void) (Msgid2), (const char *) (Msgid1)) \
+ : ((void) (Msgid1), (const char *) (Msgid2)))
+# undef dngettext
+# define dngettext(Domainname, Msgid1, Msgid2, N) \
+ ((void) (Domainname), ngettext (Msgid1, Msgid2, N))
+# undef dcngettext
+# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \
+ ((void) (Category), dngettext(Domainname, Msgid1, Msgid2, N))
+# undef textdomain
+# define textdomain(Domainname) ((const char *) (Domainname))
+# undef bindtextdomain
+# define bindtextdomain(Domainname, Dirname) \
+ ((void) (Domainname), (const char *) (Dirname))
+# undef bind_textdomain_codeset
+# define bind_textdomain_codeset(Domainname, Codeset) \
+ ((void) (Domainname), (const char *) (Codeset))
+
+#endif
+
+/* A pseudo function call that serves as a marker for the automated
+ extraction of messages, but does not call gettext(). The run-time
+ translation is done at a different place in the code.
+ The argument, String, should be a literal string. Concatenated strings
+ and other string expressions won't work.
+ The macro's expansion is not parenthesized, so that it is suitable as
+ initializer for static 'char[]' or 'const char[]' variables. */
+#define gettext_noop(String) String
+
+/* The separator between msgctxt and msgid in a .mo file. */
+#define GETTEXT_CONTEXT_GLUE "\004"
+
+/* Pseudo function calls, taking a MSGCTXT and a MSGID instead of just a
+ MSGID. MSGCTXT and MSGID must be string literals. MSGCTXT should be
+ short and rarely need to change.
+ The letter 'p' stands for 'particular' or 'special'. */
+#ifdef DEFAULT_TEXT_DOMAIN
+# define pgettext(Msgctxt, Msgid) \
+ pgettext_aux (DEFAULT_TEXT_DOMAIN, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, LC_MESSAGES)
+#else
+# define pgettext(Msgctxt, Msgid) \
+ pgettext_aux (NULL, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, LC_MESSAGES)
+#endif
+#define dpgettext(Domainname, Msgctxt, Msgid) \
+ pgettext_aux (Domainname, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, LC_MESSAGES)
+#define dcpgettext(Domainname, Msgctxt, Msgid, Category) \
+ pgettext_aux (Domainname, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, Category)
+#ifdef DEFAULT_TEXT_DOMAIN
+# define npgettext(Msgctxt, Msgid, MsgidPlural, N) \
+ npgettext_aux (DEFAULT_TEXT_DOMAIN, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, MsgidPlural, N, LC_MESSAGES)
+#else
+# define npgettext(Msgctxt, Msgid, MsgidPlural, N) \
+ npgettext_aux (NULL, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, MsgidPlural, N, LC_MESSAGES)
+#endif
+#define dnpgettext(Domainname, Msgctxt, Msgid, MsgidPlural, N) \
+ npgettext_aux (Domainname, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, MsgidPlural, N, LC_MESSAGES)
+#define dcnpgettext(Domainname, Msgctxt, Msgid, MsgidPlural, N, Category) \
+ npgettext_aux (Domainname, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, MsgidPlural, N, Category)
+
+#ifdef __GNUC__
+__inline
+#else
+#ifdef __cplusplus
+inline
+#endif
+#endif
+static const char *
+pgettext_aux (const char *domain,
+ const char *msg_ctxt_id, const char *msgid,
+ int category)
+{
+ const char *translation = dcgettext (domain, msg_ctxt_id, category);
+ if (translation == msg_ctxt_id)
+ return msgid;
+ else
+ return translation;
+}
+
+#ifdef __GNUC__
+__inline
+#else
+#ifdef __cplusplus
+inline
+#endif
+#endif
+static const char *
+npgettext_aux (const char *domain,
+ const char *msg_ctxt_id, const char *msgid,
+ const char *msgid_plural, unsigned long int n,
+ int category)
+{
+ const char *translation =
+ dcngettext (domain, msg_ctxt_id, msgid_plural, n, category);
+ if (translation == msg_ctxt_id || translation == msgid_plural)
+ return (n == 1 ? msgid : msgid_plural);
+ else
+ return translation;
+}
+
+/* The same thing extended for non-constant arguments. Here MSGCTXT and MSGID
+ can be arbitrary expressions. But for string literals these macros are
+ less efficient than those above. */
+
+#include <string.h>
+
+#define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS \
+ (((__GNUC__ >= 3 || __GNUG__ >= 2) && !__STRICT_ANSI__) \
+ /* || __STDC_VERSION__ >= 199901L */ )
+
+#if !_LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS
+#include <stdlib.h>
+#endif
+
+#define pgettext_expr(Msgctxt, Msgid) \
+ dcpgettext_expr (NULL, Msgctxt, Msgid, LC_MESSAGES)
+#define dpgettext_expr(Domainname, Msgctxt, Msgid) \
+ dcpgettext_expr (Domainname, Msgctxt, Msgid, LC_MESSAGES)
+
+#ifdef __GNUC__
+__inline
+#else
+#ifdef __cplusplus
+inline
+#endif
+#endif
+static const char *
+dcpgettext_expr (const char *domain,
+ const char *msgctxt, const char *msgid,
+ int category)
+{
+ size_t msgctxt_len = strlen (msgctxt) + 1;
+ size_t msgid_len = strlen (msgid) + 1;
+ const char *translation;
+#if _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS
+ char msg_ctxt_id[msgctxt_len + msgid_len];
+#else
+ char buf[1024];
+ char *msg_ctxt_id =
+ (msgctxt_len + msgid_len <= sizeof (buf)
+ ? buf
+ : (char *) malloc (msgctxt_len + msgid_len));
+ if (msg_ctxt_id != NULL)
+#endif
+ {
+ memcpy (msg_ctxt_id, msgctxt, msgctxt_len - 1);
+ msg_ctxt_id[msgctxt_len - 1] = '\004';
+ memcpy (msg_ctxt_id + msgctxt_len, msgid, msgid_len);
+ translation = dcgettext (domain, msg_ctxt_id, category);
+#if !_LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS
+ if (msg_ctxt_id != buf)
+ free (msg_ctxt_id);
+#endif
+ if (translation != msg_ctxt_id)
+ return translation;
+ }
+ return msgid;
+}
+
+#define npgettext_expr(Msgctxt, Msgid, MsgidPlural, N) \
+ dcnpgettext_expr (NULL, Msgctxt, Msgid, MsgidPlural, N, LC_MESSAGES)
+#define dnpgettext_expr(Domainname, Msgctxt, Msgid, MsgidPlural, N) \
+ dcnpgettext_expr (Domainname, Msgctxt, Msgid, MsgidPlural, N, LC_MESSAGES)
+
+#ifdef __GNUC__
+__inline
+#else
+#ifdef __cplusplus
+inline
+#endif
+#endif
+static const char *
+dcnpgettext_expr (const char *domain,
+ const char *msgctxt, const char *msgid,
+ const char *msgid_plural, unsigned long int n,
+ int category)
+{
+ size_t msgctxt_len = strlen (msgctxt) + 1;
+ size_t msgid_len = strlen (msgid) + 1;
+ const char *translation;
+#if _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS
+ char msg_ctxt_id[msgctxt_len + msgid_len];
+#else
+ char buf[1024];
+ char *msg_ctxt_id =
+ (msgctxt_len + msgid_len <= sizeof (buf)
+ ? buf
+ : (char *) malloc (msgctxt_len + msgid_len));
+ if (msg_ctxt_id != NULL)
+#endif
+ {
+ memcpy (msg_ctxt_id, msgctxt, msgctxt_len - 1);
+ msg_ctxt_id[msgctxt_len - 1] = '\004';
+ memcpy (msg_ctxt_id + msgctxt_len, msgid, msgid_len);
+ translation = dcngettext (domain, msg_ctxt_id, msgid_plural, n, category);
+#if !_LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS
+ if (msg_ctxt_id != buf)
+ free (msg_ctxt_id);
+#endif
+ if (!(translation == msg_ctxt_id || translation == msgid_plural))
+ return translation;
+ }
+ return (n == 1 ? msgid : msgid_plural);
+}
+
+#endif /* _LIBGETTEXT_H */
--- /dev/null
+struct mapping { int standard_name; const char vendor_name[10 + 1]; };
+%struct-type
+%language=ANSI-C
+%define slot-name standard_name
+%define hash-function-name mapping_hash
+%define lookup-function-name mapping_lookup
+%readonly-tables
+%global-table
+%define word-array-name mappings
+%pic
+%%
+# On Solaris 10, look in the "iconv -l" output. Some aliases are advertised but
+# not actually supported by the iconv() function and by the 'iconv' program.
+# For example:
+# $ echo abc | iconv -f 646 -t ISO-8859-1
+# Not supported 646 to ISO-8859-1
+# $ echo abc | iconv -f 646 -t ISO8859-1
+$ abc
+ASCII, "646"
+ISO-8859-1, "ISO8859-1"
+ISO-8859-2, "ISO8859-2"
+ISO-8859-3, "ISO8859-3"
+ISO-8859-4, "ISO8859-4"
+ISO-8859-5, "ISO8859-5"
+ISO-8859-6, "ISO8859-6"
+ISO-8859-7, "ISO8859-7"
+ISO-8859-8, "ISO8859-8"
+ISO-8859-9, "ISO8859-9"
+ISO-8859-15, "ISO8859-15"
+CP1251, "ansi-1251"
--- /dev/null
+/* ANSI-C code produced by gperf version 3.0.4 */
+/* Command-line: gperf -m 10 ./iconv_open-solaris.gperf */
+/* Computed positions: -k'10' */
+
+#if !((' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \
+ && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \
+ && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \
+ && ('-' == 45) && ('.' == 46) && ('/' == 47) && ('0' == 48) \
+ && ('1' == 49) && ('2' == 50) && ('3' == 51) && ('4' == 52) \
+ && ('5' == 53) && ('6' == 54) && ('7' == 55) && ('8' == 56) \
+ && ('9' == 57) && (':' == 58) && (';' == 59) && ('<' == 60) \
+ && ('=' == 61) && ('>' == 62) && ('?' == 63) && ('A' == 65) \
+ && ('B' == 66) && ('C' == 67) && ('D' == 68) && ('E' == 69) \
+ && ('F' == 70) && ('G' == 71) && ('H' == 72) && ('I' == 73) \
+ && ('J' == 74) && ('K' == 75) && ('L' == 76) && ('M' == 77) \
+ && ('N' == 78) && ('O' == 79) && ('P' == 80) && ('Q' == 81) \
+ && ('R' == 82) && ('S' == 83) && ('T' == 84) && ('U' == 85) \
+ && ('V' == 86) && ('W' == 87) && ('X' == 88) && ('Y' == 89) \
+ && ('Z' == 90) && ('[' == 91) && ('\\' == 92) && (']' == 93) \
+ && ('^' == 94) && ('_' == 95) && ('a' == 97) && ('b' == 98) \
+ && ('c' == 99) && ('d' == 100) && ('e' == 101) && ('f' == 102) \
+ && ('g' == 103) && ('h' == 104) && ('i' == 105) && ('j' == 106) \
+ && ('k' == 107) && ('l' == 108) && ('m' == 109) && ('n' == 110) \
+ && ('o' == 111) && ('p' == 112) && ('q' == 113) && ('r' == 114) \
+ && ('s' == 115) && ('t' == 116) && ('u' == 117) && ('v' == 118) \
+ && ('w' == 119) && ('x' == 120) && ('y' == 121) && ('z' == 122) \
+ && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126))
+/* The character set is not based on ISO-646. */
+#error "gperf generated tables don't work with this execution character set. Please report a bug to <bug-gnu-gperf@gnu.org>."
+#endif
+
+#line 1 "./iconv_open-solaris.gperf"
+struct mapping { int standard_name; const char vendor_name[10 + 1]; };
+
+#define TOTAL_KEYWORDS 13
+#define MIN_WORD_LENGTH 5
+#define MAX_WORD_LENGTH 11
+#define MIN_HASH_VALUE 5
+#define MAX_HASH_VALUE 19
+/* maximum key range = 15, duplicates = 0 */
+
+#ifdef __GNUC__
+__inline
+#else
+#ifdef __cplusplus
+inline
+#endif
+#endif
+static unsigned int
+mapping_hash (register const char *str, register unsigned int len)
+{
+ static const unsigned char asso_values[] =
+ {
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 0,
+ 9, 8, 7, 6, 5, 4, 3, 2, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20
+ };
+ register int hval = len;
+
+ switch (hval)
+ {
+ default:
+ hval += asso_values[(unsigned char)str[9]];
+ /*FALLTHROUGH*/
+ case 9:
+ case 8:
+ case 7:
+ case 6:
+ case 5:
+ break;
+ }
+ return hval;
+}
+
+struct stringpool_t
+ {
+ char stringpool_str5[sizeof("ASCII")];
+ char stringpool_str6[sizeof("CP1251")];
+ char stringpool_str7[sizeof("$ abc")];
+ char stringpool_str10[sizeof("ISO-8859-1")];
+ char stringpool_str11[sizeof("ISO-8859-15")];
+ char stringpool_str12[sizeof("ISO-8859-9")];
+ char stringpool_str13[sizeof("ISO-8859-8")];
+ char stringpool_str14[sizeof("ISO-8859-7")];
+ char stringpool_str15[sizeof("ISO-8859-6")];
+ char stringpool_str16[sizeof("ISO-8859-5")];
+ char stringpool_str17[sizeof("ISO-8859-4")];
+ char stringpool_str18[sizeof("ISO-8859-3")];
+ char stringpool_str19[sizeof("ISO-8859-2")];
+ };
+static const struct stringpool_t stringpool_contents =
+ {
+ "ASCII",
+ "CP1251",
+ "$ abc",
+ "ISO-8859-1",
+ "ISO-8859-15",
+ "ISO-8859-9",
+ "ISO-8859-8",
+ "ISO-8859-7",
+ "ISO-8859-6",
+ "ISO-8859-5",
+ "ISO-8859-4",
+ "ISO-8859-3",
+ "ISO-8859-2"
+ };
+#define stringpool ((const char *) &stringpool_contents)
+
+static const struct mapping mappings[] =
+ {
+ {-1}, {-1}, {-1}, {-1}, {-1},
+#line 19 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str5, "646"},
+#line 30 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str6, "ansi-1251"},
+#line 18 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str7},
+ {-1}, {-1},
+#line 20 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str10, "ISO8859-1"},
+#line 29 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str11, "ISO8859-15"},
+#line 28 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str12, "ISO8859-9"},
+#line 27 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str13, "ISO8859-8"},
+#line 26 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str14, "ISO8859-7"},
+#line 25 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str15, "ISO8859-6"},
+#line 24 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str16, "ISO8859-5"},
+#line 23 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str17, "ISO8859-4"},
+#line 22 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str18, "ISO8859-3"},
+#line 21 "./iconv_open-solaris.gperf"
+ {(int)(long)&((struct stringpool_t *)0)->stringpool_str19, "ISO8859-2"}
+ };
+
+#ifdef __GNUC__
+__inline
+#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__
+__attribute__ ((__gnu_inline__))
+#endif
+#endif
+const struct mapping *
+mapping_lookup (register const char *str, register unsigned int len)
+{
+ if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH)
+ {
+ register int key = mapping_hash (str, len);
+
+ if (key <= MAX_HASH_VALUE && key >= 0)
+ {
+ register int o = mappings[key].standard_name;
+ if (o >= 0)
+ {
+ register const char *s = o + stringpool;
+
+ if (*str == *s && !strcmp (str + 1, s + 1))
+ return &mappings[key];
+ }
+ }
+ }
+ return 0;
+}
/* Character set conversion.
- Copyright (C) 2007 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
#define ICONV_FLAVOR_HPUX "iconv_open-hpux.h"
#define ICONV_FLAVOR_IRIX "iconv_open-irix.h"
#define ICONV_FLAVOR_OSF "iconv_open-osf.h"
+#define ICONV_FLAVOR_SOLARIS "iconv_open-solaris.h"
#ifdef ICONV_FLAVOR
# include ICONV_FLAVOR
--- /dev/null
+/* ignore a function return without a compiler warning
+
+ Copyright (C) 2008-2009 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program 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 General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Jim Meyering. */
+
+/* Use these functions to avoid a warning when using a function declared with
+ gcc's warn_unused_result attribute, but for which you really do want to
+ ignore the result. Traditionally, people have used a "(void)" cast to
+ indicate that a function's return value is deliberately unused. However,
+ if the function is declared with __attribute__((warn_unused_result)),
+ gcc issues a warning even with the cast.
+
+ Caution: most of the time, you really should heed gcc's warning, and
+ check the return value. However, in those exceptional cases in which
+ you're sure you know what you're doing, use this function.
+
+ For the record, here's one of the ignorable warnings:
+ "copy.c:233: warning: ignoring return value of 'fchown',
+ declared with attribute warn_unused_result". */
+
+static inline void ignore_value (int i) { (void) i; }
+static inline void ignore_ptr (void* p) { (void) p; }
+/* FIXME: what about aggregate types? */
--- /dev/null
+/* inet_ntop.c -- convert IPv4 and IPv6 addresses from binary to text form
+
+ Copyright (C) 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+/*
+ * Copyright (c) 1996-1999 by Internet Software Consortium.
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND INTERNET SOFTWARE CONSORTIUM DISCLAIMS
+ * ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES
+ * OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL INTERNET SOFTWARE
+ * CONSORTIUM BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
+ * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
+ * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
+ * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+ * SOFTWARE.
+ */
+
+#include <config.h>
+
+/* Specification. */
+#include <arpa/inet.h>
+
+#include <stdio.h>
+#include <string.h>
+#include <errno.h>
+
+#define NS_IN6ADDRSZ 16
+#define NS_INT16SZ 2
+
+/*
+ * WARNING: Don't even consider trying to compile this on a system where
+ * sizeof(int) < 4. sizeof(int) > 4 is fine; all the world's not a VAX.
+ */
+typedef int verify_int_size[2 * sizeof (int) - 7];
+
+static const char *inet_ntop4 (const unsigned char *src, char *dst, socklen_t size);
+#if HAVE_IPV6
+static const char *inet_ntop6 (const unsigned char *src, char *dst, socklen_t size);
+#endif
+
+
+/* char *
+ * inet_ntop(af, src, dst, size)
+ * convert a network format address to presentation format.
+ * return:
+ * pointer to presentation format address (`dst'), or NULL (see errno).
+ * author:
+ * Paul Vixie, 1996.
+ */
+const char *
+inet_ntop (int af, const void *restrict src,
+ char *restrict dst, socklen_t cnt)
+{
+ switch (af)
+ {
+#if HAVE_IPV4
+ case AF_INET:
+ return (inet_ntop4 (src, dst, cnt));
+#endif
+
+#if HAVE_IPV6
+ case AF_INET6:
+ return (inet_ntop6 (src, dst, cnt));
+#endif
+
+ default:
+ errno = EAFNOSUPPORT;
+ return (NULL);
+ }
+ /* NOTREACHED */
+}
+
+/* const char *
+ * inet_ntop4(src, dst, size)
+ * format an IPv4 address
+ * return:
+ * `dst' (as a const)
+ * notes:
+ * (1) uses no statics
+ * (2) takes a u_char* not an in_addr as input
+ * author:
+ * Paul Vixie, 1996.
+ */
+static const char *
+inet_ntop4 (const unsigned char *src, char *dst, socklen_t size)
+{
+ char tmp[sizeof "255.255.255.255"];
+ int len;
+
+ len = sprintf (tmp, "%u.%u.%u.%u", src[0], src[1], src[2], src[3]);
+ if (len < 0)
+ return NULL;
+
+ if (len > size)
+ {
+ errno = ENOSPC;
+ return NULL;
+ }
+
+ return strcpy (dst, tmp);
+}
+
+#if HAVE_IPV6
+
+/* const char *
+ * inet_ntop6(src, dst, size)
+ * convert IPv6 binary address into presentation (printable) format
+ * author:
+ * Paul Vixie, 1996.
+ */
+static const char *
+inet_ntop6 (const unsigned char *src, char *dst, socklen_t size)
+{
+ /*
+ * Note that int32_t and int16_t need only be "at least" large enough
+ * to contain a value of the specified size. On some systems, like
+ * Crays, there is no such thing as an integer variable with 16 bits.
+ * Keep this in mind if you think this function should have been coded
+ * to use pointer overlays. All the world's not a VAX.
+ */
+ char tmp[sizeof "ffff:ffff:ffff:ffff:ffff:ffff:255.255.255.255"], *tp;
+ struct
+ {
+ int base, len;
+ } best, cur;
+ unsigned int words[NS_IN6ADDRSZ / NS_INT16SZ];
+ int i;
+
+ /*
+ * Preprocess:
+ * Copy the input (bytewise) array into a wordwise array.
+ * Find the longest run of 0x00's in src[] for :: shorthanding.
+ */
+ memset (words, '\0', sizeof words);
+ for (i = 0; i < NS_IN6ADDRSZ; i += 2)
+ words[i / 2] = (src[i] << 8) | src[i + 1];
+ best.base = -1;
+ cur.base = -1;
+ for (i = 0; i < (NS_IN6ADDRSZ / NS_INT16SZ); i++)
+ {
+ if (words[i] == 0)
+ {
+ if (cur.base == -1)
+ cur.base = i, cur.len = 1;
+ else
+ cur.len++;
+ }
+ else
+ {
+ if (cur.base != -1)
+ {
+ if (best.base == -1 || cur.len > best.len)
+ best = cur;
+ cur.base = -1;
+ }
+ }
+ }
+ if (cur.base != -1)
+ {
+ if (best.base == -1 || cur.len > best.len)
+ best = cur;
+ }
+ if (best.base != -1 && best.len < 2)
+ best.base = -1;
+
+ /*
+ * Format the result.
+ */
+ tp = tmp;
+ for (i = 0; i < (NS_IN6ADDRSZ / NS_INT16SZ); i++)
+ {
+ /* Are we inside the best run of 0x00's? */
+ if (best.base != -1 && i >= best.base && i < (best.base + best.len))
+ {
+ if (i == best.base)
+ *tp++ = ':';
+ continue;
+ }
+ /* Are we following an initial run of 0x00s or any real hex? */
+ if (i != 0)
+ *tp++ = ':';
+ /* Is this address an encapsulated IPv4? */
+ if (i == 6 && best.base == 0 &&
+ (best.len == 6 || (best.len == 5 && words[5] == 0xffff)))
+ {
+ if (!inet_ntop4 (src + 12, tp, sizeof tmp - (tp - tmp)))
+ return (NULL);
+ tp += strlen (tp);
+ break;
+ }
+ {
+ int len = sprintf (tp, "%x", words[i]);
+ if (len < 0)
+ return NULL;
+ tp += len;
+ }
+ }
+ /* Was it a trailing run of 0x00's? */
+ if (best.base != -1 && (best.base + best.len) ==
+ (NS_IN6ADDRSZ / NS_INT16SZ))
+ *tp++ = ':';
+ *tp++ = '\0';
+
+ /*
+ * Check for overflow, copy, and we're done.
+ */
+ if ((socklen_t) (tp - tmp) > size)
+ {
+ errno = ENOSPC;
+ return NULL;
+ }
+
+ return strcpy (dst, tmp);
+}
+
+#endif
--- /dev/null
+/* inet_pton.c -- convert IPv4 and IPv6 addresses from text to binary form
+
+ Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
+
+ This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+/*
+ * Copyright (c) 1996,1999 by Internet Software Consortium.
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND INTERNET SOFTWARE CONSORTIUM DISCLAIMS
+ * ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES
+ * OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL INTERNET SOFTWARE
+ * CONSORTIUM BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
+ * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
+ * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
+ * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+ * SOFTWARE.
+ */
+
+#include <config.h>
+
+/* Specification. */
+#include <arpa/inet.h>
+
+#include <c-ctype.h>
+#include <string.h>
+#include <errno.h>
+
+#define NS_INADDRSZ 4
+#define NS_IN6ADDRSZ 16
+#define NS_INT16SZ 2
+
+/*
+ * WARNING: Don't even consider trying to compile this on a system where
+ * sizeof(int) < 4. sizeof(int) > 4 is fine; all the world's not a VAX.
+ */
+
+static int inet_pton4 (const char *src, unsigned char *dst);
+#if HAVE_IPV6
+static int inet_pton6 (const char *src, unsigned char *dst);
+#endif
+
+/* int
+ * inet_pton(af, src, dst)
+ * convert from presentation format (which usually means ASCII printable)
+ * to network format (which is usually some kind of binary format).
+ * return:
+ * 1 if the address was valid for the specified address family
+ * 0 if the address wasn't valid (`dst' is untouched in this case)
+ * -1 if some other error occurred (`dst' is untouched in this case, too)
+ * author:
+ * Paul Vixie, 1996.
+ */
+int
+inet_pton (int af, const char *restrict src, void *restrict dst)
+{
+ switch (af)
+ {
+ case AF_INET:
+ return (inet_pton4 (src, dst));
+
+#if HAVE_IPV6
+ case AF_INET6:
+ return (inet_pton6 (src, dst));
+#endif
+
+ default:
+ errno = EAFNOSUPPORT;
+ return (-1);
+ }
+ /* NOTREACHED */
+}
+
+/* int
+ * inet_pton4(src, dst)
+ * like inet_aton() but without all the hexadecimal, octal (with the
+ * exception of 0) and shorthand.
+ * return:
+ * 1 if `src' is a valid dotted quad, else 0.
+ * notice:
+ * does not touch `dst' unless it's returning 1.
+ * author:
+ * Paul Vixie, 1996.
+ */
+static int
+inet_pton4 (const char *restrict src, unsigned char *restrict dst)
+{
+ int saw_digit, octets, ch;
+ unsigned char tmp[NS_INADDRSZ], *tp;
+
+ saw_digit = 0;
+ octets = 0;
+ *(tp = tmp) = 0;
+ while ((ch = *src++) != '\0')
+ {
+
+ if (ch >= '0' && ch <= '9')
+ {
+ unsigned new = *tp * 10 + (ch - '0');
+
+ if (saw_digit && *tp == 0)
+ return (0);
+ if (new > 255)
+ return (0);
+ *tp = new;
+ if (!saw_digit)
+ {
+ if (++octets > 4)
+ return (0);
+ saw_digit = 1;
+ }
+ }
+ else if (ch == '.' && saw_digit)
+ {
+ if (octets == 4)
+ return (0);
+ *++tp = 0;
+ saw_digit = 0;
+ }
+ else
+ return (0);
+ }
+ if (octets < 4)
+ return (0);
+ memcpy (dst, tmp, NS_INADDRSZ);
+ return (1);
+}
+
+#if HAVE_IPV6
+
+/* int
+ * inet_pton6(src, dst)
+ * convert presentation level address to network order binary form.
+ * return:
+ * 1 if `src' is a valid [RFC1884 2.2] address, else 0.
+ * notice:
+ * (1) does not touch `dst' unless it's returning 1.
+ * (2) :: in a full address is silently ignored.
+ * credit:
+ * inspired by Mark Andrews.
+ * author:
+ * Paul Vixie, 1996.
+ */
+static int
+inet_pton6 (const char *restrict src, unsigned char *restrict dst)
+{
+ static const char xdigits[] = "0123456789abcdef";
+ unsigned char tmp[NS_IN6ADDRSZ], *tp, *endp, *colonp;
+ const char *curtok;
+ int ch, saw_xdigit;
+ unsigned val;
+
+ tp = memset (tmp, '\0', NS_IN6ADDRSZ);
+ endp = tp + NS_IN6ADDRSZ;
+ colonp = NULL;
+ /* Leading :: requires some special handling. */
+ if (*src == ':')
+ if (*++src != ':')
+ return (0);
+ curtok = src;
+ saw_xdigit = 0;
+ val = 0;
+ while ((ch = c_tolower (*src++)) != '\0')
+ {
+ const char *pch;
+
+ pch = strchr (xdigits, ch);
+ if (pch != NULL)
+ {
+ val <<= 4;
+ val |= (pch - xdigits);
+ if (val > 0xffff)
+ return (0);
+ saw_xdigit = 1;
+ continue;
+ }
+ if (ch == ':')
+ {
+ curtok = src;
+ if (!saw_xdigit)
+ {
+ if (colonp)
+ return (0);
+ colonp = tp;
+ continue;
+ }
+ else if (*src == '\0')
+ {
+ return (0);
+ }
+ if (tp + NS_INT16SZ > endp)
+ return (0);
+ *tp++ = (u_char) (val >> 8) & 0xff;
+ *tp++ = (u_char) val & 0xff;
+ saw_xdigit = 0;
+ val = 0;
+ continue;
+ }
+ if (ch == '.' && ((tp + NS_INADDRSZ) <= endp) &&
+ inet_pton4 (curtok, tp) > 0)
+ {
+ tp += NS_INADDRSZ;
+ saw_xdigit = 0;
+ break; /* '\0' was seen by inet_pton4(). */
+ }
+ return (0);
+ }
+ if (saw_xdigit)
+ {
+ if (tp + NS_INT16SZ > endp)
+ return (0);
+ *tp++ = (u_char) (val >> 8) & 0xff;
+ *tp++ = (u_char) val & 0xff;
+ }
+ if (colonp != NULL)
+ {
+ /*
+ * Since some memmove()'s erroneously fail to handle
+ * overlapping regions, we'll do the shift by hand.
+ */
+ const int n = tp - colonp;
+ int i;
+
+ if (tp == endp)
+ return (0);
+ for (i = 1; i <= n; i++)
+ {
+ endp[-i] = colonp[n - i];
+ colonp[n - i] = 0;
+ }
+ tp = endp;
+ }
+ if (tp != endp)
+ return (0);
+ memcpy (dst, tmp, NS_IN6ADDRSZ);
+ return (1);
+}
+#endif
/* Specification. */
#include "localcharset.h"
+#include <fcntl.h>
#include <stddef.h>
#include <stdio.h>
#include <string.h>
#endif
#if !defined WIN32_NATIVE
+# include <unistd.h>
# if HAVE_LANGINFO_CODESET
# include <langinfo.h>
# else
# include "configmake.h"
#endif
+/* Define O_NOFOLLOW to 0 on platforms where it does not exist. */
+#ifndef O_NOFOLLOW
+# define O_NOFOLLOW 0
+#endif
+
#if defined _WIN32 || defined __WIN32__ || defined __CYGWIN__ || defined __EMX__ || defined __DJGPP__
/* Win32, Cygwin, OS/2, DOS */
# define ISSLASH(C) ((C) == '/' || (C) == '\\')
if (cp == NULL)
{
#if !(defined DARWIN7 || defined VMS || defined WIN32_NATIVE || defined __CYGWIN__)
- FILE *fp;
const char *dir;
const char *base = "charset.alias";
char *file_name;
}
}
- if (file_name == NULL || (fp = fopen (file_name, "r")) == NULL)
- /* Out of memory or file not found, treat it as empty. */
+ if (file_name == NULL)
+ /* Out of memory. Treat the file as empty. */
cp = "";
else
{
- /* Parse the file's contents. */
- char *res_ptr = NULL;
- size_t res_size = 0;
-
- for (;;)
+ int fd;
+
+ /* Open the file. Reject symbolic links on platforms that support
+ O_NOFOLLOW. This is a security feature. Without it, an attacker
+ could retrieve parts of the contents (namely, the tail of the
+ first line that starts with "* ") of an arbitrary file by placing
+ a symbolic link to that file under the name "charset.alias" in
+ some writable directory and defining the environment variable
+ CHARSETALIASDIR to point to that directory. */
+ fd = open (file_name,
+ O_RDONLY | (HAVE_WORKING_O_NOFOLLOW ? O_NOFOLLOW : 0));
+ if (fd < 0)
+ /* File not found. Treat it as empty. */
+ cp = "";
+ else
{
- int c;
- char buf1[50+1];
- char buf2[50+1];
- size_t l1, l2;
- char *old_res_ptr;
-
- c = getc (fp);
- if (c == EOF)
- break;
- if (c == '\n' || c == ' ' || c == '\t')
- continue;
- if (c == '#')
- {
- /* Skip comment, to end of line. */
- do
- c = getc (fp);
- while (!(c == EOF || c == '\n'));
- if (c == EOF)
- break;
- continue;
- }
- ungetc (c, fp);
- if (fscanf (fp, "%50s %50s", buf1, buf2) < 2)
- break;
- l1 = strlen (buf1);
- l2 = strlen (buf2);
- old_res_ptr = res_ptr;
- if (res_size == 0)
+ FILE *fp;
+
+ fp = fdopen (fd, "r");
+ if (fp == NULL)
{
- res_size = l1 + 1 + l2 + 1;
- res_ptr = (char *) malloc (res_size + 1);
+ /* Out of memory. Treat the file as empty. */
+ close (fd);
+ cp = "";
}
else
{
- res_size += l1 + 1 + l2 + 1;
- res_ptr = (char *) realloc (res_ptr, res_size + 1);
+ /* Parse the file's contents. */
+ char *res_ptr = NULL;
+ size_t res_size = 0;
+
+ for (;;)
+ {
+ int c;
+ char buf1[50+1];
+ char buf2[50+1];
+ size_t l1, l2;
+ char *old_res_ptr;
+
+ c = getc (fp);
+ if (c == EOF)
+ break;
+ if (c == '\n' || c == ' ' || c == '\t')
+ continue;
+ if (c == '#')
+ {
+ /* Skip comment, to end of line. */
+ do
+ c = getc (fp);
+ while (!(c == EOF || c == '\n'));
+ if (c == EOF)
+ break;
+ continue;
+ }
+ ungetc (c, fp);
+ if (fscanf (fp, "%50s %50s", buf1, buf2) < 2)
+ break;
+ l1 = strlen (buf1);
+ l2 = strlen (buf2);
+ old_res_ptr = res_ptr;
+ if (res_size == 0)
+ {
+ res_size = l1 + 1 + l2 + 1;
+ res_ptr = (char *) malloc (res_size + 1);
+ }
+ else
+ {
+ res_size += l1 + 1 + l2 + 1;
+ res_ptr = (char *) realloc (res_ptr, res_size + 1);
+ }
+ if (res_ptr == NULL)
+ {
+ /* Out of memory. */
+ res_size = 0;
+ if (old_res_ptr != NULL)
+ free (old_res_ptr);
+ break;
+ }
+ strcpy (res_ptr + res_size - (l2 + 1) - (l1 + 1), buf1);
+ strcpy (res_ptr + res_size - (l2 + 1), buf2);
+ }
+ fclose (fp);
+ if (res_size == 0)
+ cp = "";
+ else
+ {
+ *(res_ptr + res_size) = '\0';
+ cp = res_ptr;
+ }
}
- if (res_ptr == NULL)
- {
- /* Out of memory. */
- res_size = 0;
- if (old_res_ptr != NULL)
- free (old_res_ptr);
- break;
- }
- strcpy (res_ptr + res_size - (l2 + 1) - (l1 + 1), buf1);
- strcpy (res_ptr + res_size - (l2 + 1), buf2);
- }
- fclose (fp);
- if (res_size == 0)
- cp = "";
- else
- {
- *(res_ptr + res_size) = '\0';
- cp = res_ptr;
}
- }
- if (file_name != NULL)
- free (file_name);
+ free (file_name);
+ }
#else
--- /dev/null
+/* A POSIX <locale.h>.
+ Copyright (C) 2007-2009 Free Software Foundation, Inc.
+
+ This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef _GL_LOCALE_H
+
+#if __GNUC__ >= 3
+@PRAGMA_SYSTEM_HEADER@
+#endif
+
+/* The include_next requires a split double-inclusion guard. */
+#@INCLUDE_NEXT@ @NEXT_LOCALE_H@
+
+#ifndef _GL_LOCALE_H
+#define _GL_LOCALE_H
+
+/* NetBSD 5.0 mis-defines NULL. */
+#include <stddef.h>
+
+/* MacOS X 10.5 defines the locale_t type in <xlocale.h>. */
+#if @HAVE_XLOCALE_H@
+# include <xlocale.h>
+#endif
+
+/* The LC_MESSAGES locale category is specified in POSIX, but not in ISO C.
+ On systems that don't define it, use the same value as GNU libintl. */
+#if !defined LC_MESSAGES
+# define LC_MESSAGES 1729
+#endif
+
+#if @GNULIB_DUPLOCALE@
+# if @REPLACE_DUPLOCALE@
+# undef duplocale
+# define duplocale rpl_duplocale
+extern locale_t duplocale (locale_t locale);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef duplocale
+# define duplocale(l) \
+ (GL_LINK_WARNING ("duplocale is buggy on some glibc systems - " \
+ "use gnulib module duplocale for portability"), \
+ duplocale (l))
+#endif
+
+#endif /* _GL_LOCALE_H */
+#endif /* _GL_LOCALE_H */
--- /dev/null
+/* Work around a bug of lstat on some systems
+
+ Copyright (C) 1997-1999, 2000-2006, 2008-2009 Free Software
+ Foundation, Inc.
+
+ This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* written by Jim Meyering */
+
+#include <config.h>
+
+#if !HAVE_LSTAT
+/* On systems that lack symlinks, our replacement <sys/stat.h> already
+ defined lstat as stat, so there is nothing further to do other than
+ avoid an empty file. */
+typedef int dummy;
+#else /* HAVE_LSTAT */
+
+/* Get the original definition of lstat. It might be defined as a macro. */
+# define __need_system_sys_stat_h
+# include <sys/types.h>
+# include <sys/stat.h>
+# undef __need_system_sys_stat_h
+
+static inline int
+orig_lstat (const char *filename, struct stat *buf)
+{
+ return lstat (filename, buf);
+}
+
+/* Specification. */
+# include <sys/stat.h>
+
+# include <string.h>
+# include <errno.h>
+
+/* lstat works differently on Linux and Solaris systems. POSIX (see
+ `pathname resolution' in the glossary) requires that programs like
+ `ls' take into consideration the fact that FILE has a trailing slash
+ when FILE is a symbolic link. On Linux and Solaris 10 systems, the
+ lstat function already has the desired semantics (in treating
+ `lstat ("symlink/", sbuf)' just like `lstat ("symlink/.", sbuf)',
+ but on Solaris 9 and earlier it does not.
+
+ If FILE has a trailing slash and specifies a symbolic link,
+ then use stat() to get more info on the referent of FILE.
+ If the referent is a non-directory, then set errno to ENOTDIR
+ and return -1. Otherwise, return stat's result. */
+
+int
+rpl_lstat (const char *file, struct stat *sbuf)
+{
+ size_t len;
+ int lstat_result = orig_lstat (file, sbuf);
+
+ if (lstat_result != 0)
+ return lstat_result;
+
+ /* This replacement file can blindly check against '/' rather than
+ using the ISSLASH macro, because all platforms with '\\' either
+ lack symlinks (mingw) or have working lstat (cygwin) and thus do
+ not compile this file. 0 len should have already been filtered
+ out above, with a failure return of ENOENT. */
+ len = strlen (file);
+ if (file[len - 1] != '/' || S_ISDIR (sbuf->st_mode))
+ return 0;
+
+ /* At this point, a trailing slash is only permitted on
+ symlink-to-dir; but it should have found information on the
+ directory, not the symlink. Call stat() to get info about the
+ link's referent. Our replacement stat guarantees valid results,
+ even if the symlink is not pointing to a directory. */
+ if (!S_ISLNK (sbuf->st_mode))
+ {
+ errno = ENOTDIR;
+ return -1;
+ }
+ return stat (file, sbuf);
+}
+
+#endif /* HAVE_LSTAT */
--- /dev/null
+/* Substitute for <netinet/in.h>.
+ Copyright (C) 2007-2008 Free Software Foundation, Inc.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef _GL_NETINET_IN_H
+
+#if @HAVE_NETINET_IN_H@
+
+# if __GNUC__ >= 3
+@PRAGMA_SYSTEM_HEADER@
+# endif
+
+/* On many platforms, <netinet/in.h> assumes prior inclusion of
+ <sys/types.h>. */
+# include <sys/types.h>
+
+/* The include_next requires a split double-inclusion guard. */
+# @INCLUDE_NEXT@ @NEXT_NETINET_IN_H@
+
+#endif
+
+#ifndef _GL_NETINET_IN_H
+#define _GL_NETINET_IN_H
+
+#if !@HAVE_NETINET_IN_H@
+
+/* A platform that lacks <netinet/in.h>. */
+
+# include <sys/socket.h>
+
+#endif
+
+#endif /* _GL_NETINET_IN_H */
+#endif /* _GL_NETINET_IN_H */
/* Decomposed printf argument list.
- Copyright (C) 1999, 2002-2003, 2005-2007 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2002-2003, 2005-2007, 2009 Free Software
+ Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
where wint_t is 'unsigned short'. */
ap->a.a_wide_char =
(sizeof (wint_t) < sizeof (int)
- ? va_arg (args, int)
+ ? (wint_t) va_arg (args, int)
: va_arg (args, wint_t));
break;
#endif
/* Stub for readlink().
- Copyright (C) 2003-2007 Free Software Foundation, Inc.
+ Copyright (C) 2003-2007, 2009 Free Software Foundation, Inc.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
#include <unistd.h>
#include <errno.h>
-#include <sys/types.h>
+#include <string.h>
#include <sys/stat.h>
-#include <stddef.h>
#if !HAVE_READLINK
/* readlink() substitute for systems that don't have a readlink() function,
such as DJGPP 2.03 and mingw32. */
-/* The official POSIX return type of readlink() is ssize_t, but since here
- we have no declaration in a public header file, we use 'int' as return
- type. */
-
-int
-readlink (const char *path, char *buf, size_t bufsize)
+ssize_t
+readlink (const char *name, char *buf _UNUSED_PARAMETER_,
+ size_t bufsize _UNUSED_PARAMETER_)
{
struct stat statbuf;
/* In general we should use lstat() here, not stat(). But on platforms
- without symbolic links lstat() - if it exists - would be equivalent to
+ without symbolic links, lstat() - if it exists - would be equivalent to
stat(), therefore we can use stat(). This saves us a configure check. */
- if (stat (path, &statbuf) >= 0)
+ if (stat (name, &statbuf) >= 0)
errno = EINVAL;
return -1;
}
-#endif
+#else /* HAVE_READLINK */
+
+# undef readlink
+
+/* readlink() wrapper that uses correct types, for systems like cygwin
+ 1.5.x where readlink returns int, and which rejects trailing slash,
+ for Solaris 9. */
+
+ssize_t
+rpl_readlink (const char *name, char *buf, size_t bufsize)
+{
+# if READLINK_TRAILING_SLASH_BUG
+ size_t len = strlen (name);
+ if (len && name[len - 1] == '/')
+ {
+ /* Even if name without the slash is a symlink to a directory,
+ both lstat() and stat() must resolve the trailing slash to
+ the directory rather than the symlink. We can therefore
+ safely use stat() to distinguish between EINVAL and
+ ENOTDIR/ENOENT, avoiding extra overhead of rpl_lstat(). */
+ struct stat st;
+ if (stat (name, &st) == 0)
+ errno = EINVAL;
+ return -1;
+ }
+# endif /* READLINK_TRAILING_SLASH_BUG */
+ return readlink (name, buf, bufsize);
+}
+
+#endif /* HAVE_READLINK */
--- /dev/null
+/* Work around platform bugs in stat.
+ Copyright (C) 2009 Free Software Foundation, Inc.
+
+ This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* written by Eric Blake */
+
+#include <config.h>
+
+/* Get the original definition of stat. It might be defined as a macro. */
+#define __need_system_sys_stat_h
+#include <sys/types.h>
+#include <sys/stat.h>
+#undef __need_system_sys_stat_h
+
+static inline int
+orig_stat (const char *filename, struct stat *buf)
+{
+ return stat (filename, buf);
+}
+
+/* Specification. */
+#include <sys/stat.h>
+
+#include <errno.h>
+#include <limits.h>
+#include <stdbool.h>
+#include <string.h>
+
+/* Store information about NAME into ST. Work around bugs with
+ trailing slashes. Mingw has other bugs (such as st_ino always
+ being 0 on success) which this wrapper does not work around. But
+ at least this implementation provides the ability to emulate fchdir
+ correctly. */
+
+int
+rpl_stat (char const *name, struct stat *st)
+{
+ int result = orig_stat (name, st);
+#if REPLACE_FUNC_STAT_FILE
+ /* Solaris 9 mistakenly succeeds when given a non-directory with a
+ trailing slash. */
+ if (result == 0 && !S_ISDIR (st->st_mode))
+ {
+ size_t len = strlen (name);
+ if (ISSLASH (name[len - 1]))
+ {
+ errno = ENOTDIR;
+ return -1;
+ }
+ }
+#endif /* REPLACE_FUNC_STAT_FILE */
+#if REPLACE_FUNC_STAT_DIR
+ if (result == -1 && errno == ENOENT)
+ {
+ /* Due to mingw's oddities, there are some directories (like
+ c:\) where stat() only succeeds with a trailing slash, and
+ other directories (like c:\windows) where stat() only
+ succeeds without a trailing slash. But we want the two to be
+ synonymous, since chdir() manages either style. Likewise, Mingw also
+ reports ENOENT for names longer than PATH_MAX, when we want
+ ENAMETOOLONG, and for stat("file/"), when we want ENOTDIR.
+ Fortunately, mingw PATH_MAX is small enough for stack
+ allocation. */
+ char fixed_name[PATH_MAX + 1] = {0};
+ size_t len = strlen (name);
+ bool check_dir = false;
+ if (PATH_MAX <= len)
+ errno = ENAMETOOLONG;
+ else if (len)
+ {
+ strcpy (fixed_name, name);
+ if (ISSLASH (fixed_name[len - 1]))
+ {
+ check_dir = true;
+ while (len && ISSLASH (fixed_name[len - 1]))
+ fixed_name[--len] = '\0';
+ if (!len)
+ fixed_name[0] = '/';
+ }
+ else
+ fixed_name[len++] = '/';
+ result = orig_stat (fixed_name, st);
+ if (result == 0 && check_dir && !S_ISDIR (st->st_mode))
+ {
+ result = -1;
+ errno = ENOTDIR;
+ }
+ }
+ }
+#endif /* REPLACE_FUNC_STAT_DIR */
+ return result;
+}
--- /dev/null
+/* Substitute for and wrapper around <stdarg.h>.
+ Copyright (C) 2008 Free Software Foundation, Inc.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef _GL_STDARG_H
+
+#if __GNUC__ >= 3
+@PRAGMA_SYSTEM_HEADER@
+#endif
+
+/* The include_next requires a split double-inclusion guard. */
+#@INCLUDE_NEXT@ @NEXT_STDARG_H@
+
+#ifndef _GL_STDARG_H
+#define _GL_STDARG_H
+
+#ifndef va_copy
+# define va_copy(a,b) ((a) = (b))
+#endif
+
+#endif /* _GL_STDARG_H */
+#endif /* _GL_STDARG_H */
--- /dev/null
+/* A substitute for POSIX 2008 <stddef.h>, for platforms that have issues.
+
+ Copyright (C) 2009 Free Software Foundation, Inc.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+/* Written by Eric Blake. */
+
+/*
+ * POSIX 2008 <stddef.h> for platforms that have issues.
+ * <http://www.opengroup.org/susv3xbd/stddef.h.html>
+ */
+
+#if __GNUC__ >= 3
+@PRAGMA_SYSTEM_HEADER@
+#endif
+
+#if defined __need_wchar_t || defined __need_size_t \
+ || defined __need_ptrdiff_t || defined __need_NULL \
+ || defined __need_wint_t
+/* Special invocation convention inside gcc header files. In
+ particular, gcc provides a version of <stddef.h> that blindly
+ redefines NULL even when __need_wint_t was defined, even though
+ wint_t is not normally provided by <stddef.h>. Hence, we must
+ remember if special invocation has ever been used to obtain wint_t,
+ in which case we need to clean up NULL yet again. */
+
+# if !(defined _GL_STDDEF_H && defined _GL_STDDEF_WINT_T)
+# ifdef __need_wint_t
+# undef _GL_STDDEF_H
+# define _GL_STDDEF_WINT_T
+# endif
+# @INCLUDE_NEXT@ @NEXT_STDDEF_H@
+# endif
+
+#else
+/* Normal invocation convention. */
+
+# ifndef _GL_STDDEF_H
+
+/* The include_next requires a split double-inclusion guard. */
+
+# @INCLUDE_NEXT@ @NEXT_STDDEF_H@
+
+# ifndef _GL_STDDEF_H
+# define _GL_STDDEF_H
+
+/* On NetBSD 5.0, the definition of NULL lacks proper parentheses. */
+#if @REPLACE_NULL@
+# undef NULL
+# ifdef __cplusplus
+ /* ISO C++ says that the macro NULL must expand to an integer constant
+ expression, hence '((void *) 0)' is not allowed in C++. */
+# if __GNUG__ >= 3
+ /* GNU C++ has a __null macro that behaves like an integer ('int' or
+ 'long') but has the same size as a pointer. Use that, to avoid
+ warnings. */
+# define NULL __null
+# else
+# define NULL 0L
+# endif
+# else
+# define NULL ((void *) 0)
+# endif
+#endif
+
+/* Some platforms lack wchar_t. */
+#if !@HAVE_WCHAR_T@
+# define wchar_t int
+#endif
+
+# endif /* _GL_STDDEF_H */
+# endif /* _GL_STDDEF_H */
+#endif /* __need_XXX */
/* POSIX compatible FILE stream write function.
- Copyright (C) 2008 Free Software Foundation, Inc.
+ Copyright (C) 2008-2009 Free Software Foundation, Inc.
Written by Bruno Haible <bruno@clisp.org>, 2008.
This program is free software: you can redistribute it and/or modify
}
# if !REPLACE_PRINTF_POSIX /* avoid collision with printf.c */
+# if !DEPENDS_ON_LIBINTL /* avoid collision with intl/printf.c */
int
printf (const char *format, ...)
{
return retval;
}
+# endif
# endif
# if !REPLACE_FPRINTF_POSIX /* avoid collision with fprintf.c */
}
# endif
-# if !REPLACE_VFPRINTF_POSIX /* avoid collision with vprintf.c */
+# if !REPLACE_VPRINTF_POSIX /* avoid collision with vprintf.c */
int
vprintf (const char *format, va_list args)
{
}
# endif
-# if !REPLACE_VPRINTF_POSIX /* avoid collision with vfprintf.c */
+# if !REPLACE_VFPRINTF_POSIX /* avoid collision with vfprintf.c */
int
vfprintf (FILE *stream, const char *format, va_list args)
#undef vfprintf
extern "C" {
#endif
-
-#if @GNULIB_FPRINTF_POSIX@
-# if @REPLACE_FPRINTF@
-# define fprintf rpl_fprintf
-extern int fprintf (FILE *fp, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3)));
-# endif
-#elif @GNULIB_FPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# define fprintf rpl_fprintf
-extern int fprintf (FILE *fp, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3)));
-#elif defined GNULIB_POSIXCHECK
-# undef fprintf
-# define fprintf \
- (GL_LINK_WARNING ("fprintf is not always POSIX compliant - " \
- "use gnulib module fprintf-posix for portable " \
- "POSIX compliance"), \
- fprintf)
-#endif
-
-#if @GNULIB_VFPRINTF_POSIX@
-# if @REPLACE_VFPRINTF@
-# define vfprintf rpl_vfprintf
-extern int vfprintf (FILE *fp, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)));
-# endif
-#elif @GNULIB_VFPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# define vfprintf rpl_vfprintf
-extern int vfprintf (FILE *fp, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)));
-#elif defined GNULIB_POSIXCHECK
-# undef vfprintf
-# define vfprintf(s,f,a) \
- (GL_LINK_WARNING ("vfprintf is not always POSIX compliant - " \
- "use gnulib module vfprintf-posix for portable " \
- "POSIX compliance"), \
- vfprintf (s, f, a))
-#endif
-
-#if @GNULIB_PRINTF_POSIX@
-# if @REPLACE_PRINTF@
-/* Don't break __attribute__((format(printf,M,N))). */
-# define printf __printf__
-extern int printf (const char *format, ...)
- __attribute__ ((__format__ (__printf__, 1, 2)));
-# endif
-#elif @GNULIB_PRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-/* Don't break __attribute__((format(printf,M,N))). */
-# define printf __printf__
-extern int printf (const char *format, ...)
- __attribute__ ((__format__ (__printf__, 1, 2)));
-#elif defined GNULIB_POSIXCHECK
-# undef printf
-# define printf \
- (GL_LINK_WARNING ("printf is not always POSIX compliant - " \
- "use gnulib module printf-posix for portable " \
- "POSIX compliance"), \
- printf)
-/* Don't break __attribute__((format(printf,M,N))). */
-# define format(kind,m,n) format (__##kind##__, m, n)
-# define __format__(kind,m,n) __format__ (__##kind##__, m, n)
-# define ____printf____ __printf__
-# define ____scanf____ __scanf__
-# define ____strftime____ __strftime__
-# define ____strfmon____ __strfmon__
-#endif
-
-#if @GNULIB_VPRINTF_POSIX@
-# if @REPLACE_VPRINTF@
-# define vprintf rpl_vprintf
-extern int vprintf (const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 1, 0)));
-# endif
-#elif @GNULIB_VPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# define vprintf rpl_vprintf
-extern int vprintf (const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 1, 0)));
-#elif defined GNULIB_POSIXCHECK
-# undef vprintf
-# define vprintf(f,a) \
- (GL_LINK_WARNING ("vprintf is not always POSIX compliant - " \
- "use gnulib module vprintf-posix for portable " \
- "POSIX compliance"), \
- vprintf (f, a))
-#endif
-
-#if @GNULIB_SNPRINTF@
-# if @REPLACE_SNPRINTF@
-# define snprintf rpl_snprintf
-# endif
-# if @REPLACE_SNPRINTF@ || !@HAVE_DECL_SNPRINTF@
-extern int snprintf (char *str, size_t size, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 3, 4)));
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef snprintf
-# define snprintf \
- (GL_LINK_WARNING ("snprintf is unportable - " \
- "use gnulib module snprintf for portability"), \
- snprintf)
-#endif
-
-#if @GNULIB_VSNPRINTF@
-# if @REPLACE_VSNPRINTF@
-# define vsnprintf rpl_vsnprintf
-# endif
-# if @REPLACE_VSNPRINTF@ || !@HAVE_DECL_VSNPRINTF@
-extern int vsnprintf (char *str, size_t size, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 3, 0)));
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef vsnprintf
-# define vsnprintf(b,s,f,a) \
- (GL_LINK_WARNING ("vsnprintf is unportable - " \
- "use gnulib module vsnprintf for portability"), \
- vsnprintf (b, s, f, a))
-#endif
-
-#if @GNULIB_SPRINTF_POSIX@
-# if @REPLACE_SPRINTF@
-# define sprintf rpl_sprintf
-extern int sprintf (char *str, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3)));
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef sprintf
-# define sprintf \
- (GL_LINK_WARNING ("sprintf is not always POSIX compliant - " \
- "use gnulib module sprintf-posix for portable " \
- "POSIX compliance"), \
- sprintf)
-#endif
-
-#if @GNULIB_VSPRINTF_POSIX@
-# if @REPLACE_VSPRINTF@
-# define vsprintf rpl_vsprintf
-extern int vsprintf (char *str, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)));
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef vsprintf
-# define vsprintf(b,f,a) \
- (GL_LINK_WARNING ("vsprintf is not always POSIX compliant - " \
- "use gnulib module vsprintf-posix for portable " \
- "POSIX compliance"), \
- vsprintf (b, f, a))
-#endif
-
#if @GNULIB_DPRINTF@
# if @REPLACE_DPRINTF@
# define dprintf rpl_dprintf
dprintf (d, f, a))
#endif
-#if @GNULIB_VDPRINTF@
-# if @REPLACE_VDPRINTF@
-# define vdprintf rpl_vdprintf
-# endif
-# if @REPLACE_VDPRINTF@ || !@HAVE_VDPRINTF@
-extern int vdprintf (int fd, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)));
+#if @GNULIB_FCLOSE@
+# if @REPLACE_FCLOSE@
+# define fclose rpl_fclose
+ /* Close STREAM and its underlying file descriptor. */
+extern int fclose (FILE *stream);
# endif
#elif defined GNULIB_POSIXCHECK
-# undef vdprintf
-# define vdprintf(d,f,a) \
- (GL_LINK_WARNING ("vdprintf is unportable - " \
- "use gnulib module vdprintf for portability"), \
- vdprintf (d, f, a))
-#endif
-
-#if @GNULIB_VASPRINTF@
-# if @REPLACE_VASPRINTF@
-# define asprintf rpl_asprintf
-# define vasprintf rpl_vasprintf
-# endif
-# if @REPLACE_VASPRINTF@ || !@HAVE_VASPRINTF@
- /* Write formatted output to a string dynamically allocated with malloc().
- If the memory allocation succeeds, store the address of the string in
- *RESULT and return the number of resulting bytes, excluding the trailing
- NUL. Upon memory allocation error, or some other error, return -1. */
- extern int asprintf (char **result, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3)));
- extern int vasprintf (char **result, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)));
-# endif
+# undef fclose
+# define fclose(f) \
+ (GL_LINK_WARNING ("fclose is not always POSIX compliant - " \
+ "use gnulib module fclose for portable " \
+ "POSIX compliance"), \
+ fclose (f))
#endif
-#if @GNULIB_OBSTACK_PRINTF@
-# if @REPLACE_OBSTACK_PRINTF@
-# define obstack_printf rpl_osbtack_printf
-# define obstack_vprintf rpl_obstack_vprintf
-# endif
-# if @REPLACE_OBSTACK_PRINTF@ || !@HAVE_DECL_OBSTACK_PRINTF@
- struct obstack;
- /* Grow an obstack with formatted output. Return the number of
- bytes added to OBS. No trailing nul byte is added, and the
- object should be closed with obstack_finish before use. Upon
- memory allocation error, call obstack_alloc_failed_handler. Upon
- other error, return -1. */
- extern int obstack_printf (struct obstack *obs, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3)));
- extern int obstack_vprintf (struct obstack *obs, const char *format,
- va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)));
+#if @GNULIB_FFLUSH@
+# if @REPLACE_FFLUSH@
+# define fflush rpl_fflush
+ /* Flush all pending data on STREAM according to POSIX rules. Both
+ output and seekable input streams are supported.
+ Note! LOSS OF DATA can occur if fflush is applied on an input stream
+ that is _not_seekable_ or on an update stream that is _not_seekable_
+ and in which the most recent operation was input. Seekability can
+ be tested with lseek(fileno(fp),0,SEEK_CUR). */
+ extern int fflush (FILE *gl_stream);
# endif
+#elif defined GNULIB_POSIXCHECK
+# undef fflush
+# define fflush(f) \
+ (GL_LINK_WARNING ("fflush is not always POSIX compliant - " \
+ "use gnulib module fflush for portable " \
+ "POSIX compliance"), \
+ fflush (f))
#endif
#if @GNULIB_FOPEN@
fopen (f, m))
#endif
+#if @GNULIB_FPRINTF_POSIX@
+# if @REPLACE_FPRINTF@
+# define fprintf rpl_fprintf
+extern int fprintf (FILE *fp, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)));
+# endif
+#elif @GNULIB_FPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# define fprintf rpl_fprintf
+extern int fprintf (FILE *fp, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)));
+#elif defined GNULIB_POSIXCHECK
+# undef fprintf
+# define fprintf \
+ (GL_LINK_WARNING ("fprintf is not always POSIX compliant - " \
+ "use gnulib module fprintf-posix for portable " \
+ "POSIX compliance"), \
+ fprintf)
+#endif
+
+#if @GNULIB_FPURGE@
+# if @REPLACE_FPURGE@
+# define fpurge rpl_fpurge
+# endif
+# if @REPLACE_FPURGE@ || !@HAVE_DECL_FPURGE@
+ /* Discard all pending buffered I/O data on STREAM.
+ STREAM must not be wide-character oriented.
+ When discarding pending output, the file position is set back to where it
+ was before the write calls. When discarding pending input, the file
+ position is advanced to match the end of the previously read input.
+ Return 0 if successful. Upon error, return -1 and set errno. */
+ extern int fpurge (FILE *gl_stream);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef fpurge
+# define fpurge(f) \
+ (GL_LINK_WARNING ("fpurge is not always present - " \
+ "use gnulib module fpurge for portability"), \
+ fpurge (f))
+#endif
+
+#if @GNULIB_FPUTC@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# undef fputc
+# define fputc rpl_fputc
+extern int fputc (int c, FILE *stream);
+#endif
+
+#if @GNULIB_FPUTS@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# undef fputs
+# define fputs rpl_fputs
+extern int fputs (const char *string, FILE *stream);
+#endif
+
#if @GNULIB_FREOPEN@
# if @REPLACE_FREOPEN@
# undef freopen
freopen (f, m, s))
#endif
-#if @GNULIB_FSEEKO@
-# if @REPLACE_FSEEKO@
-/* Provide fseek, fseeko functions that are aware of a preceding
- fflush(), and which detect pipes. */
-# define fseeko rpl_fseeko
-extern int fseeko (FILE *fp, off_t offset, int whence);
-# define fseek(fp, offset, whence) fseeko (fp, (off_t)(offset), whence)
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef fseeko
-# define fseeko(f,o,w) \
- (GL_LINK_WARNING ("fseeko is unportable - " \
- "use gnulib module fseeko for portability"), \
- fseeko (f, o, w))
-#endif
-
#if @GNULIB_FSEEK@ && @REPLACE_FSEEK@
extern int rpl_fseek (FILE *fp, long offset, int whence);
# undef fseek
# endif
#endif
-#if @GNULIB_FTELLO@
-# if @REPLACE_FTELLO@
-# define ftello rpl_ftello
-extern off_t ftello (FILE *fp);
-# define ftell(fp) ftello (fp)
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef ftello
-# define ftello(f) \
- (GL_LINK_WARNING ("ftello is unportable - " \
- "use gnulib module ftello for portability"), \
- ftello (f))
-#endif
-
-#if @GNULIB_FTELL@ && @REPLACE_FTELL@
-extern long rpl_ftell (FILE *fp);
-# undef ftell
-# if GNULIB_POSIXCHECK
-# define ftell(f) \
- (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \
- "on 32-bit platforms - " \
- "use ftello function for handling of large files"), \
- rpl_ftell (f))
-# else
-# define ftell rpl_ftell
-# endif
-#elif defined GNULIB_POSIXCHECK
-# ifndef ftell
-# define ftell(f) \
- (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \
+#if @GNULIB_FSEEKO@
+# if @REPLACE_FSEEKO@
+/* Provide fseek, fseeko functions that are aware of a preceding
+ fflush(), and which detect pipes. */
+# define fseeko rpl_fseeko
+extern int fseeko (FILE *fp, off_t offset, int whence);
+# if !@GNULIB_FSEEK@
+# undef fseek
+# define fseek(f,o,w) \
+ (GL_LINK_WARNING ("fseek cannot handle files larger than 4 GB " \
"on 32-bit platforms - " \
- "use ftello function for handling of large files"), \
- ftell (f))
-# endif
-#endif
-
-#if @GNULIB_FFLUSH@
-# if @REPLACE_FFLUSH@
-# define fflush rpl_fflush
- /* Flush all pending data on STREAM according to POSIX rules. Both
- output and seekable input streams are supported.
- Note! LOSS OF DATA can occur if fflush is applied on an input stream
- that is _not_seekable_ or on an update stream that is _not_seekable_
- and in which the most recent operation was input. Seekability can
- be tested with lseek(fileno(fp),0,SEEK_CUR). */
- extern int fflush (FILE *gl_stream);
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef fflush
-# define fflush(f) \
- (GL_LINK_WARNING ("fflush is not always POSIX compliant - " \
- "use gnulib module fflush for portable " \
- "POSIX compliance"), \
- fflush (f))
-#endif
-
-#if @GNULIB_FPURGE@
-# if @REPLACE_FPURGE@
-# define fpurge rpl_fpurge
-# endif
-# if @REPLACE_FPURGE@ || !@HAVE_DECL_FPURGE@
- /* Discard all pending buffered I/O data on STREAM.
- STREAM must not be wide-character oriented.
- Return 0 if successful. Upon error, return -1 and set errno. */
- extern int fpurge (FILE *gl_stream);
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef fpurge
-# define fpurge(f) \
- (GL_LINK_WARNING ("fpurge is not always present - " \
- "use gnulib module fpurge for portability"), \
- fpurge (f))
-#endif
-
-#if @GNULIB_FCLOSE@
-# if @REPLACE_FCLOSE@
-# define fclose rpl_fclose
- /* Close STREAM and its underlying file descriptor. */
-extern int fclose (FILE *stream);
+ "use fseeko function for handling of large files"), \
+ fseeko (f, o, w))
+# endif
# endif
#elif defined GNULIB_POSIXCHECK
-# undef fclose
-# define fclose(f) \
- (GL_LINK_WARNING ("fclose is not always POSIX compliant - " \
- "use gnulib module fclose for portable " \
- "POSIX compliance"), \
- fclose (f))
-#endif
-
-#if @GNULIB_FPUTC@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef fputc
-# define fputc rpl_fputc
-extern int fputc (int c, FILE *stream);
-#endif
-
-#if @GNULIB_PUTC@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef putc
-# define putc rpl_fputc
-extern int putc (int c, FILE *stream);
-#endif
-
-#if @GNULIB_PUTCHAR@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef putchar
-# define putchar rpl_putchar
-extern int putchar (int c);
-#endif
-
-#if @GNULIB_FPUTS@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef fputs
-# define fputs rpl_fputs
-extern int fputs (const char *string, FILE *stream);
+# undef fseeko
+# define fseeko(f,o,w) \
+ (GL_LINK_WARNING ("fseeko is unportable - " \
+ "use gnulib module fseeko for portability"), \
+ fseeko (f, o, w))
#endif
-#if @GNULIB_PUTS@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef puts
-# define puts rpl_puts
-extern int puts (const char *string);
+#if @GNULIB_FTELL@ && @REPLACE_FTELL@
+extern long rpl_ftell (FILE *fp);
+# undef ftell
+# if GNULIB_POSIXCHECK
+# define ftell(f) \
+ (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \
+ "on 32-bit platforms - " \
+ "use ftello function for handling of large files"), \
+ rpl_ftell (f))
+# else
+# define ftell rpl_ftell
+# endif
+#elif defined GNULIB_POSIXCHECK
+# ifndef ftell
+# define ftell(f) \
+ (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \
+ "on 32-bit platforms - " \
+ "use ftello function for handling of large files"), \
+ ftell (f))
+# endif
+#endif
+
+#if @GNULIB_FTELLO@
+# if @REPLACE_FTELLO@
+# define ftello rpl_ftello
+extern off_t ftello (FILE *fp);
+# if !@GNULIB_FTELL@
+# undef ftell
+# define ftell(f) \
+ (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \
+ "on 32-bit platforms - " \
+ "use ftello function for handling of large files"), \
+ ftello (f))
+# endif
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef ftello
+# define ftello(f) \
+ (GL_LINK_WARNING ("ftello is unportable - " \
+ "use gnulib module ftello for portability"), \
+ ftello (f))
#endif
#if @GNULIB_FWRITE@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
getline (l, s, f))
#endif
+#if @GNULIB_OBSTACK_PRINTF@
+# if @REPLACE_OBSTACK_PRINTF@
+# define obstack_printf rpl_osbtack_printf
+# define obstack_vprintf rpl_obstack_vprintf
+# endif
+# if @REPLACE_OBSTACK_PRINTF@ || !@HAVE_DECL_OBSTACK_PRINTF@
+ struct obstack;
+ /* Grow an obstack with formatted output. Return the number of
+ bytes added to OBS. No trailing nul byte is added, and the
+ object should be closed with obstack_finish before use. Upon
+ memory allocation error, call obstack_alloc_failed_handler. Upon
+ other error, return -1. */
+ extern int obstack_printf (struct obstack *obs, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)));
+ extern int obstack_vprintf (struct obstack *obs, const char *format,
+ va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)));
+# endif
+#endif
+
#if @GNULIB_PERROR@
# if @REPLACE_PERROR@
# define perror rpl_perror
perror (s))
#endif
+#if @GNULIB_POPEN@
+# if @REPLACE_POPEN@
+# undef popen
+# define popen rpl_popen
+extern FILE *popen (const char *cmd, const char *mode);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef popen
+# define popen(c,m) \
+ (GL_LINK_WARNING ("popen is buggy on some platforms - " \
+ "use gnulib module popen or pipe for more portability"), \
+ popen (c, m))
+#endif
+
+#if @GNULIB_PRINTF_POSIX@
+# if @REPLACE_PRINTF@
+/* Don't break __attribute__((format(printf,M,N))). */
+# define printf __printf__
+extern int printf (const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 1, 2)));
+# endif
+#elif @GNULIB_PRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+/* Don't break __attribute__((format(printf,M,N))). */
+# define printf __printf__
+extern int printf (const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 1, 2)));
+#elif defined GNULIB_POSIXCHECK
+# undef printf
+# define printf \
+ (GL_LINK_WARNING ("printf is not always POSIX compliant - " \
+ "use gnulib module printf-posix for portable " \
+ "POSIX compliance"), \
+ printf)
+/* Don't break __attribute__((format(printf,M,N))). */
+# define format(kind,m,n) format (__##kind##__, m, n)
+# define __format__(kind,m,n) __format__ (__##kind##__, m, n)
+# define ____printf____ __printf__
+# define ____scanf____ __scanf__
+# define ____strftime____ __strftime__
+# define ____strfmon____ __strfmon__
+#endif
+
+#if @GNULIB_PUTC@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# undef putc
+# define putc rpl_fputc
+extern int putc (int c, FILE *stream);
+#endif
+
+#if @GNULIB_PUTCHAR@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# undef putchar
+# define putchar rpl_putchar
+extern int putchar (int c);
+#endif
+
+#if @GNULIB_PUTS@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# undef puts
+# define puts rpl_puts
+extern int puts (const char *string);
+#endif
+
+#if @GNULIB_REMOVE@
+# if @REPLACE_REMOVE@
+# undef remove
+# define remove rpl_remove
+extern int remove (const char *name);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef remove
+# define remove(n) \
+ (GL_LINK_WARNING ("remove cannot handle directories on some platforms - " \
+ "use gnulib module remove for more portability"), \
+ remove (n))
+#endif
+
+#if @GNULIB_RENAME@
+# if @REPLACE_RENAME@
+# undef rename
+# define rename rpl_rename
+extern int rename (const char *old, const char *new);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef rename
+# define rename(o,n) \
+ (GL_LINK_WARNING ("rename is buggy on some platforms - " \
+ "use gnulib module rename for more portability"), \
+ rename (o, n))
+#endif
+
+#if @GNULIB_RENAMEAT@
+# if @REPLACE_RENAMEAT@
+# undef renameat
+# define renameat rpl_renameat
+# endif
+# if !@HAVE_RENAMEAT@ || @REPLACE_RENAMEAT@
+extern int renameat (int fd1, char const *file1, int fd2, char const *file2);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef renameat
+# define renameat(d1,f1,d2,f2) \
+ (GL_LINK_WARNING ("renameat is not portable - " \
+ "use gnulib module renameat for portability"), \
+ renameat (d1, f1, d2, f2))
+#endif
+
+#if @GNULIB_SNPRINTF@
+# if @REPLACE_SNPRINTF@
+# define snprintf rpl_snprintf
+# endif
+# if @REPLACE_SNPRINTF@ || !@HAVE_DECL_SNPRINTF@
+extern int snprintf (char *str, size_t size, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 3, 4)));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef snprintf
+# define snprintf \
+ (GL_LINK_WARNING ("snprintf is unportable - " \
+ "use gnulib module snprintf for portability"), \
+ snprintf)
+#endif
+
+#if @GNULIB_SPRINTF_POSIX@
+# if @REPLACE_SPRINTF@
+# define sprintf rpl_sprintf
+extern int sprintf (char *str, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef sprintf
+# define sprintf \
+ (GL_LINK_WARNING ("sprintf is not always POSIX compliant - " \
+ "use gnulib module sprintf-posix for portable " \
+ "POSIX compliance"), \
+ sprintf)
+#endif
+
+#if @GNULIB_VASPRINTF@
+# if @REPLACE_VASPRINTF@
+# define asprintf rpl_asprintf
+# define vasprintf rpl_vasprintf
+# endif
+# if @REPLACE_VASPRINTF@ || !@HAVE_VASPRINTF@
+ /* Write formatted output to a string dynamically allocated with malloc().
+ If the memory allocation succeeds, store the address of the string in
+ *RESULT and return the number of resulting bytes, excluding the trailing
+ NUL. Upon memory allocation error, or some other error, return -1. */
+ extern int asprintf (char **result, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)));
+ extern int vasprintf (char **result, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)));
+# endif
+#endif
+
+#if @GNULIB_VDPRINTF@
+# if @REPLACE_VDPRINTF@
+# define vdprintf rpl_vdprintf
+# endif
+# if @REPLACE_VDPRINTF@ || !@HAVE_VDPRINTF@
+extern int vdprintf (int fd, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef vdprintf
+# define vdprintf(d,f,a) \
+ (GL_LINK_WARNING ("vdprintf is unportable - " \
+ "use gnulib module vdprintf for portability"), \
+ vdprintf (d, f, a))
+#endif
+
+#if @GNULIB_VFPRINTF_POSIX@
+# if @REPLACE_VFPRINTF@
+# define vfprintf rpl_vfprintf
+extern int vfprintf (FILE *fp, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)));
+# endif
+#elif @GNULIB_VFPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# define vfprintf rpl_vfprintf
+extern int vfprintf (FILE *fp, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)));
+#elif defined GNULIB_POSIXCHECK
+# undef vfprintf
+# define vfprintf(s,f,a) \
+ (GL_LINK_WARNING ("vfprintf is not always POSIX compliant - " \
+ "use gnulib module vfprintf-posix for portable " \
+ "POSIX compliance"), \
+ vfprintf (s, f, a))
+#endif
+
+#if @GNULIB_VPRINTF_POSIX@
+# if @REPLACE_VPRINTF@
+# define vprintf rpl_vprintf
+extern int vprintf (const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 1, 0)));
+# endif
+#elif @GNULIB_VPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# define vprintf rpl_vprintf
+extern int vprintf (const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 1, 0)));
+#elif defined GNULIB_POSIXCHECK
+# undef vprintf
+# define vprintf(f,a) \
+ (GL_LINK_WARNING ("vprintf is not always POSIX compliant - " \
+ "use gnulib module vprintf-posix for portable " \
+ "POSIX compliance"), \
+ vprintf (f, a))
+#endif
+
+#if @GNULIB_VSNPRINTF@
+# if @REPLACE_VSNPRINTF@
+# define vsnprintf rpl_vsnprintf
+# endif
+# if @REPLACE_VSNPRINTF@ || !@HAVE_DECL_VSNPRINTF@
+extern int vsnprintf (char *str, size_t size, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 3, 0)));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef vsnprintf
+# define vsnprintf(b,s,f,a) \
+ (GL_LINK_WARNING ("vsnprintf is unportable - " \
+ "use gnulib module vsnprintf for portability"), \
+ vsnprintf (b, s, f, a))
+#endif
+
+#if @GNULIB_VSPRINTF_POSIX@
+# if @REPLACE_VSPRINTF@
+# define vsprintf rpl_vsprintf
+extern int vsprintf (char *str, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef vsprintf
+# define vsprintf(b,f,a) \
+ (GL_LINK_WARNING ("vsprintf is not always POSIX compliant - " \
+ "use gnulib module vsprintf-posix for portable " \
+ "POSIX compliance"), \
+ vsprintf (b, f, a))
+#endif
+
#ifdef __cplusplus
}
#endif
#ifndef _GL_STDLIB_H
#define _GL_STDLIB_H
+/* NetBSD 5.0 mis-defines NULL. */
+#include <stddef.h>
/* Solaris declares getloadavg() in <sys/loadavg.h>. */
#if @GNULIB_GETLOADAVG@ && @HAVE_SYS_LOADAVG_H@
extern "C" {
#endif
-
-#if @GNULIB_MALLOC_POSIX@
-# if !@HAVE_MALLOC_POSIX@
-# undef malloc
-# define malloc rpl_malloc
-extern void * malloc (size_t size);
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef malloc
-# define malloc(s) \
- (GL_LINK_WARNING ("malloc is not POSIX compliant everywhere - " \
- "use gnulib module malloc-posix for portability"), \
- malloc (s))
-#endif
-
-
-#if @GNULIB_REALLOC_POSIX@
-# if !@HAVE_REALLOC_POSIX@
-# undef realloc
-# define realloc rpl_realloc
-extern void * realloc (void *ptr, size_t size);
+#if @GNULIB_ATOLL@
+# if !@HAVE_ATOLL@
+/* Parse a signed decimal integer.
+ Returns the value of the integer. Errors are not detected. */
+extern long long atoll (const char *string);
# endif
#elif defined GNULIB_POSIXCHECK
-# undef realloc
-# define realloc(p,s) \
- (GL_LINK_WARNING ("realloc is not POSIX compliant everywhere - " \
- "use gnulib module realloc-posix for portability"), \
- realloc (p, s))
+# undef atoll
+# define atoll(s) \
+ (GL_LINK_WARNING ("atoll is unportable - " \
+ "use gnulib module atoll for portability"), \
+ atoll (s))
#endif
-
#if @GNULIB_CALLOC_POSIX@
# if !@HAVE_CALLOC_POSIX@
# undef calloc
calloc (n, s))
#endif
-
-#if @GNULIB_ATOLL@
-# if !@HAVE_ATOLL@
-/* Parse a signed decimal integer.
- Returns the value of the integer. Errors are not detected. */
-extern long long atoll (const char *string);
+#if @GNULIB_CANONICALIZE_FILE_NAME@
+# if @REPLACE_CANONICALIZE_FILE_NAME@
+# define canonicalize_file_name rpl_canonicalize_file_name
+# endif
+# if !@HAVE_CANONICALIZE_FILE_NAME@ || @REPLACE_CANONICALIZE_FILE_NAME@
+extern char *canonicalize_file_name (const char *name);
# endif
#elif defined GNULIB_POSIXCHECK
-# undef atoll
-# define atoll(s) \
- (GL_LINK_WARNING ("atoll is unportable - " \
- "use gnulib module atoll for portability"), \
- atoll (s))
+# undef canonicalize_file_name
+# define canonicalize_file_name(n) \
+ (GL_LINK_WARNING ("canonicalize_file_name is unportable - " \
+ "use gnulib module canonicalize-lgpl for portability"), \
+ canonicalize_file_name (n))
#endif
-
#if @GNULIB_GETLOADAVG@
# if !@HAVE_DECL_GETLOADAVG@
/* Store max(NELEM,3) load average numbers in LOADAVG[].
getloadavg (l, n))
#endif
-
#if @GNULIB_GETSUBOPT@
/* Assuming *OPTIONP is a comma separated list of elements of the form
"token" or "token=value", getsubopt parses the first of these elements.
getsubopt (o, t, v))
#endif
+#if @GNULIB_MALLOC_POSIX@
+# if !@HAVE_MALLOC_POSIX@
+# undef malloc
+# define malloc rpl_malloc
+extern void * malloc (size_t size);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef malloc
+# define malloc(s) \
+ (GL_LINK_WARNING ("malloc is not POSIX compliant everywhere - " \
+ "use gnulib module malloc-posix for portability"), \
+ malloc (s))
+#endif
#if @GNULIB_MKDTEMP@
# if !@HAVE_MKDTEMP@
mkdtemp (t))
#endif
+#if @GNULIB_MKOSTEMP@
+# if !@HAVE_MKOSTEMP@
+/* Create a unique temporary file from TEMPLATE.
+ The last six characters of TEMPLATE must be "XXXXXX";
+ they are replaced with a string that makes the file name unique.
+ The flags are a bitmask, possibly including O_CLOEXEC (defined in <fcntl.h>)
+ and O_TEXT, O_BINARY (defined in "binary-io.h").
+ The file is then created, with the specified flags, ensuring it didn't exist
+ before.
+ The file is created read-write (mask at least 0600 & ~umask), but it may be
+ world-readable and world-writable (mask 0666 & ~umask), depending on the
+ implementation.
+ Returns the open file descriptor if successful, otherwise -1 and errno
+ set. */
+extern int mkostemp (char * /*template*/, int /*flags*/);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mkostemp
+# define mkostemp(t,f) \
+ (GL_LINK_WARNING ("mkostemp is unportable - " \
+ "use gnulib module mkostemp for portability"), \
+ mkostemp (t, f))
+#endif
+
+#if @GNULIB_MKOSTEMPS@
+# if !@HAVE_MKOSTEMPS@
+/* Create a unique temporary file from TEMPLATE.
+ The last six characters of TEMPLATE before a suffix of length
+ SUFFIXLEN must be "XXXXXX";
+ they are replaced with a string that makes the file name unique.
+ The flags are a bitmask, possibly including O_CLOEXEC (defined in <fcntl.h>)
+ and O_TEXT, O_BINARY (defined in "binary-io.h").
+ The file is then created, with the specified flags, ensuring it didn't exist
+ before.
+ The file is created read-write (mask at least 0600 & ~umask), but it may be
+ world-readable and world-writable (mask 0666 & ~umask), depending on the
+ implementation.
+ Returns the open file descriptor if successful, otherwise -1 and errno
+ set. */
+extern int mkostemps (char * /*template*/, int /*suffixlen*/, int /*flags*/);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mkostemps
+# define mkostemps(t,s,f) \
+ (GL_LINK_WARNING ("mkostemps is unportable - " \
+ "use gnulib module mkostemps for portability"), \
+ mkostemps (t, s, f))
+#endif
#if @GNULIB_MKSTEMP@
# if @REPLACE_MKSTEMP@
mkstemp (t))
#endif
+#if @GNULIB_MKSTEMPS@
+# if !@HAVE_MKSTEMPS@
+/* Create a unique temporary file from TEMPLATE.
+ The last six characters of TEMPLATE prior to a suffix of length
+ SUFFIXLEN must be "XXXXXX";
+ they are replaced with a string that makes the file name unique.
+ The file is then created, ensuring it didn't exist before.
+ The file is created read-write (mask at least 0600 & ~umask), but it may be
+ world-readable and world-writable (mask 0666 & ~umask), depending on the
+ implementation.
+ Returns the open file descriptor if successful, otherwise -1 and errno
+ set. */
+extern int mkstemps (char * /*template*/, int /*suffixlen*/);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mkstemps
+# define mkstemps(t,s) \
+ (GL_LINK_WARNING ("mkstemps is unportable - " \
+ "use gnulib module mkstemps for portability"), \
+ mkstemps (t, s))
+#endif
#if @GNULIB_PUTENV@
# if @REPLACE_PUTENV@
# endif
#endif
-
#if @GNULIB_RANDOM_R@
# if !@HAVE_RANDOM_R@
setstate_r (a,r))
#endif
+#if @GNULIB_REALLOC_POSIX@
+# if !@HAVE_REALLOC_POSIX@
+# undef realloc
+# define realloc rpl_realloc
+extern void * realloc (void *ptr, size_t size);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef realloc
+# define realloc(p,s) \
+ (GL_LINK_WARNING ("realloc is not POSIX compliant everywhere - " \
+ "use gnulib module realloc-posix for portability"), \
+ realloc (p, s))
+#endif
+
+#if @GNULIB_REALPATH@
+# if @REPLACE_REALPATH@
+# define realpath rpl_realpath
+# endif
+# if !@HAVE_REALPATH@ || @REPLACE_REALPATH@
+extern char *realpath (const char *name, char *resolved);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef realpath
+# define realpath(n,r) \
+ (GL_LINK_WARNING ("realpath is unportable - use gnulib module " \
+ "canonicalize or canonicalize-lgpl for portability"), \
+ realpath (n, r))
+#endif
#if @GNULIB_RPMATCH@
# if !@HAVE_RPMATCH@
rpmatch (r))
#endif
-
#if @GNULIB_SETENV@
-# if !@HAVE_SETENV@
+# if @REPLACE_SETENV@
+# undef setenv
+# define setenv rpl_setenv
+# endif
+# if !@HAVE_SETENV@ || @REPLACE_SETENV@
/* Set NAME to VALUE in the environment.
If REPLACE is nonzero, overwrite an existing value. */
extern int setenv (const char *name, const char *value, int replace);
# endif
+#elif defined GNULIB_POSIXCHECK
+# undef setenv
+# define setenv(n,v,o) \
+ (GL_LINK_WARNING ("setenv is unportable - " \
+ "use gnulib module setenv for portability"), \
+ setenv (n, v, o))
#endif
-
-#if @GNULIB_UNSETENV@
-# if @HAVE_UNSETENV@
-# if @VOID_UNSETENV@
-/* On some systems, unsetenv() returns void.
- This is the case for MacOS X 10.3, FreeBSD 4.8, NetBSD 1.6, OpenBSD 3.4. */
-# define unsetenv(name) ((unsetenv)(name), 0)
-# endif
-# else
-/* Remove the variable NAME from the environment. */
-extern int unsetenv (const char *name);
-# endif
-#endif
-
-
#if @GNULIB_STRTOD@
# if @REPLACE_STRTOD@
# define strtod rpl_strtod
strtod (s, e))
#endif
-
#if @GNULIB_STRTOLL@
# if !@HAVE_STRTOLL@
/* Parse a signed integer whose textual representation starts at STRING.
strtoll (s, e, b))
#endif
-
#if @GNULIB_STRTOULL@
# if !@HAVE_STRTOULL@
/* Parse an unsigned integer whose textual representation starts at STRING.
strtoull (s, e, b))
#endif
+#if @GNULIB_UNSETENV@
+# if @REPLACE_UNSETENV@
+# undef unsetenv
+# define unsetenv rpl_unsetenv
+# endif
+# if !@HAVE_UNSETENV@ || @REPLACE_UNSETENV@
+/* Remove the variable NAME from the environment. */
+extern int unsetenv (const char *name);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef unsetenv
+# define unsetenv(n) \
+ (GL_LINK_WARNING ("unsetenv is unportable - " \
+ "use gnulib module unsetenv for portability"), \
+ unsetenv (n))
+#endif
#ifdef __cplusplus
}
#else
# include <config.h>
# if FPRINTFTIME
+# include "ignore-value.h"
# include "fprintftime.h"
# else
# include "strftime.h"
#if FPRINTFTIME
# define cpy(n, s) \
add ((n), \
+ do \
+ { \
if (to_lowcase) \
fwrite_lowcase (p, (s), _n); \
else if (to_uppcase) \
fwrite_uppcase (p, (s), _n); \
else \
- fwrite ((s), _n, 1, p))
+ { \
+ /* We are ignoring the value of fwrite here, in spite of the \
+ fact that technically, that may not be valid: the fwrite \
+ specification in POSIX 2008 defers to that of fputc, which \
+ is intended to be consistent with the one from ISO C, \
+ which permits failure due to ENOMEM *without* setting the \
+ stream's error indicator. */ \
+ ignore_value (fwrite ((s), _n, 1, p)); \
+ } \
+ } \
+ while (0) \
+ )
#else
# define cpy(n, s) \
add ((n), \
#include <time.h>
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/* Just like strftime, but with two more arguments:
POSIX requires that strftime use the local timezone information.
When __UTC is nonzero and tm->tm_zone is NULL or the empty string,
%N directive. */
size_t nstrftime (char *, size_t, char const *, struct tm const *,
int __utc, int __ns);
+
+#ifdef __cplusplus
+}
+#endif
/* Character set conversion with error handling.
- Copyright (C) 2001-2008 Free Software Foundation, Inc.
+ Copyright (C) 2001-2009 Free Software Foundation, Inc.
Written by Bruno Haible and Simon Josefsson.
This program is free software: you can redistribute it and/or modify
#if HAVE_ICONV
-/* The caller must provide CD, CD1, CD2, not just CD, because when a conversion
- error occurs, we may have to determine the Unicode representation of the
- inconvertible character. */
+/* The caller must provide an iconveh_t, not just an iconv_t, because when a
+ conversion error occurs, we may have to determine the Unicode representation
+ of the inconvertible character. */
+
+int
+iconveh_open (const char *to_codeset, const char *from_codeset, iconveh_t *cdp)
+{
+ iconv_t cd;
+ iconv_t cd1;
+ iconv_t cd2;
+
+ /* Avoid glibc-2.1 bug with EUC-KR. */
+# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined _LIBICONV_VERSION
+ if (c_strcasecmp (from_codeset, "EUC-KR") == 0
+ || c_strcasecmp (to_codeset, "EUC-KR") == 0)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+# endif
+
+ cd = iconv_open (to_codeset, from_codeset);
+
+ if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0))
+ cd1 = (iconv_t)(-1);
+ else
+ {
+ cd1 = iconv_open ("UTF-8", from_codeset);
+ if (cd1 == (iconv_t)(-1))
+ {
+ int saved_errno = errno;
+ if (cd != (iconv_t)(-1))
+ iconv_close (cdp->cd);
+ errno = saved_errno;
+ return -1;
+ }
+ }
+
+ if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)
+# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 || _LIBICONV_VERSION >= 0x0105
+ || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0
+# endif
+ )
+ cd2 = (iconv_t)(-1);
+ else
+ {
+ cd2 = iconv_open (to_codeset, "UTF-8");
+ if (cd2 == (iconv_t)(-1))
+ {
+ int saved_errno = errno;
+ if (cd1 != (iconv_t)(-1))
+ iconv_close (cd1);
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ errno = saved_errno;
+ return -1;
+ }
+ }
+
+ cdp->cd = cd;
+ cdp->cd1 = cd1;
+ cdp->cd2 = cd2;
+ return 0;
+}
+
+int
+iconveh_close (const iconveh_t *cd)
+{
+ if (cd->cd2 != (iconv_t)(-1) && iconv_close (cd->cd2) < 0)
+ {
+ /* Return -1, but preserve the errno from iconv_close. */
+ int saved_errno = errno;
+ if (cd->cd1 != (iconv_t)(-1))
+ iconv_close (cd->cd1);
+ if (cd->cd != (iconv_t)(-1))
+ iconv_close (cd->cd);
+ errno = saved_errno;
+ return -1;
+ }
+ if (cd->cd1 != (iconv_t)(-1) && iconv_close (cd->cd1) < 0)
+ {
+ /* Return -1, but preserve the errno from iconv_close. */
+ int saved_errno = errno;
+ if (cd->cd != (iconv_t)(-1))
+ iconv_close (cd->cd);
+ errno = saved_errno;
+ return -1;
+ }
+ if (cd->cd != (iconv_t)(-1) && iconv_close (cd->cd) < 0)
+ return -1;
+ return 0;
+}
/* iconv_carefully is like iconv, except that it stops as soon as it encounters
a conversion error, and it returns in *INCREMENTED a boolean telling whether
in1ptr++;
in1size--;
}
- utf8buf[utf8len++] = '?';
+ *out1ptr++ = '?';
+ res1 = 0;
}
errno1 = errno;
utf8len = out1ptr - utf8buf;
int
mem_cd_iconveh (const char *src, size_t srclen,
- iconv_t cd, iconv_t cd1, iconv_t cd2,
+ const iconveh_t *cd,
enum iconv_ilseq_handler handler,
size_t *offsets,
char **resultp, size_t *lengthp)
{
- return mem_cd_iconveh_internal (src, srclen, cd, cd1, cd2, handler, 0,
- offsets, resultp, lengthp);
+ return mem_cd_iconveh_internal (src, srclen, cd->cd, cd->cd1, cd->cd2,
+ handler, 0, offsets, resultp, lengthp);
}
char *
str_cd_iconveh (const char *src,
- iconv_t cd, iconv_t cd1, iconv_t cd2,
+ const iconveh_t *cd,
enum iconv_ilseq_handler handler)
{
/* For most encodings, a trailing NUL byte in the input will be converted
char *result = NULL;
size_t length = 0;
int retval = mem_cd_iconveh_internal (src, strlen (src),
- cd, cd1, cd2, handler, 1, NULL,
- &result, &length);
+ cd->cd, cd->cd1, cd->cd2, handler, 1,
+ NULL, &result, &length);
if (retval < 0)
{
else
{
#if HAVE_ICONV
- iconv_t cd;
- iconv_t cd1;
- iconv_t cd2;
+ iconveh_t cd;
char *result;
size_t length;
int retval;
- /* Avoid glibc-2.1 bug with EUC-KR. */
-# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined _LIBICONV_VERSION
- if (c_strcasecmp (from_codeset, "EUC-KR") == 0
- || c_strcasecmp (to_codeset, "EUC-KR") == 0)
- {
- errno = EINVAL;
- return -1;
- }
-# endif
-
- cd = iconv_open (to_codeset, from_codeset);
-
- if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0))
- cd1 = (iconv_t)(-1);
- else
- {
- cd1 = iconv_open ("UTF-8", from_codeset);
- if (cd1 == (iconv_t)(-1))
- {
- int saved_errno = errno;
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
- errno = saved_errno;
- return -1;
- }
- }
-
- if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)
-# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 || _LIBICONV_VERSION >= 0x0105
- || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0
-# endif
- )
- cd2 = (iconv_t)(-1);
- else
- {
- cd2 = iconv_open (to_codeset, "UTF-8");
- if (cd2 == (iconv_t)(-1))
- {
- int saved_errno = errno;
- if (cd1 != (iconv_t)(-1))
- iconv_close (cd1);
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
- errno = saved_errno;
- return -1;
- }
- }
+ if (iconveh_open (to_codeset, from_codeset, &cd) < 0)
+ return -1;
result = *resultp;
length = *lengthp;
- retval = mem_cd_iconveh (src, srclen, cd, cd1, cd2, handler, offsets,
+ retval = mem_cd_iconveh (src, srclen, &cd, handler, offsets,
&result, &length);
if (retval < 0)
{
- /* Close cd, cd1, cd2, but preserve the errno from str_cd_iconv. */
+ /* Close cd, but preserve the errno from str_cd_iconv. */
int saved_errno = errno;
- if (cd2 != (iconv_t)(-1))
- iconv_close (cd2);
- if (cd1 != (iconv_t)(-1))
- iconv_close (cd1);
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
+ iconveh_close (&cd);
errno = saved_errno;
}
else
{
- if (cd2 != (iconv_t)(-1) && iconv_close (cd2) < 0)
- {
- /* Return -1, but free the allocated memory, and while doing
- that, preserve the errno from iconv_close. */
- int saved_errno = errno;
- if (cd1 != (iconv_t)(-1))
- iconv_close (cd1);
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
- if (result != *resultp && result != NULL)
- free (result);
- errno = saved_errno;
- return -1;
- }
- if (cd1 != (iconv_t)(-1) && iconv_close (cd1) < 0)
+ if (iconveh_close (&cd) < 0)
{
/* Return -1, but free the allocated memory, and while doing
- that, preserve the errno from iconv_close. */
- int saved_errno = errno;
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
- if (result != *resultp && result != NULL)
- free (result);
- errno = saved_errno;
- return -1;
- }
- if (cd != (iconv_t)(-1) && iconv_close (cd) < 0)
- {
- /* Return -1, but free the allocated memory, and while doing
- that, preserve the errno from iconv_close. */
+ that, preserve the errno from iconveh_close. */
int saved_errno = errno;
if (result != *resultp && result != NULL)
free (result);
else
{
#if HAVE_ICONV
- iconv_t cd;
- iconv_t cd1;
- iconv_t cd2;
+ iconveh_t cd;
char *result;
- /* Avoid glibc-2.1 bug with EUC-KR. */
-# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined _LIBICONV_VERSION
- if (c_strcasecmp (from_codeset, "EUC-KR") == 0
- || c_strcasecmp (to_codeset, "EUC-KR") == 0)
- {
- errno = EINVAL;
- return NULL;
- }
-# endif
+ if (iconveh_open (to_codeset, from_codeset, &cd) < 0)
+ return NULL;
- cd = iconv_open (to_codeset, from_codeset);
-
- if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0))
- cd1 = (iconv_t)(-1);
- else
- {
- cd1 = iconv_open ("UTF-8", from_codeset);
- if (cd1 == (iconv_t)(-1))
- {
- int saved_errno = errno;
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
- errno = saved_errno;
- return NULL;
- }
- }
-
- if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)
-# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 || _LIBICONV_VERSION >= 0x0105
- || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0
-# endif
- )
- cd2 = (iconv_t)(-1);
- else
- {
- cd2 = iconv_open (to_codeset, "UTF-8");
- if (cd2 == (iconv_t)(-1))
- {
- int saved_errno = errno;
- if (cd1 != (iconv_t)(-1))
- iconv_close (cd1);
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
- errno = saved_errno;
- return NULL;
- }
- }
-
- result = str_cd_iconveh (src, cd, cd1, cd2, handler);
+ result = str_cd_iconveh (src, &cd, handler);
if (result == NULL)
{
- /* Close cd, cd1, cd2, but preserve the errno from str_cd_iconv. */
+ /* Close cd, but preserve the errno from str_cd_iconv. */
int saved_errno = errno;
- if (cd2 != (iconv_t)(-1))
- iconv_close (cd2);
- if (cd1 != (iconv_t)(-1))
- iconv_close (cd1);
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
+ iconveh_close (&cd);
errno = saved_errno;
}
else
{
- if (cd2 != (iconv_t)(-1) && iconv_close (cd2) < 0)
- {
- /* Return NULL, but free the allocated memory, and while doing
- that, preserve the errno from iconv_close. */
- int saved_errno = errno;
- if (cd1 != (iconv_t)(-1))
- iconv_close (cd1);
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
- free (result);
- errno = saved_errno;
- return NULL;
- }
- if (cd1 != (iconv_t)(-1) && iconv_close (cd1) < 0)
- {
- /* Return NULL, but free the allocated memory, and while doing
- that, preserve the errno from iconv_close. */
- int saved_errno = errno;
- if (cd != (iconv_t)(-1))
- iconv_close (cd);
- free (result);
- errno = saved_errno;
- return NULL;
- }
- if (cd != (iconv_t)(-1) && iconv_close (cd) < 0)
+ if (iconveh_close (&cd) < 0)
{
/* Return NULL, but free the allocated memory, and while doing
- that, preserve the errno from iconv_close. */
+ that, preserve the errno from iconveh_close. */
int saved_errno = errno;
free (result);
errno = saved_errno;
#if HAVE_ICONV
+/* An conversion descriptor for use by the iconveh functions. */
+typedef struct
+ {
+ /* Conversion descriptor from FROM_CODESET to TO_CODESET, or (iconv_t)(-1)
+ if the system does not support a direct conversion from FROM_CODESET to
+ TO_CODESET. */
+ iconv_t cd;
+ /* Conversion descriptor from FROM_CODESET to UTF-8 (or (iconv_t)(-1) if
+ FROM_CODESET is UTF-8). */
+ iconv_t cd1;
+ /* Conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1) if
+ TO_CODESET is UTF-8). */
+ iconv_t cd2;
+ }
+ iconveh_t;
+
+/* Open a conversion descriptor for use by the iconveh functions.
+ If successful, fills *CDP and returns 0. Upon failure, return -1 with errno
+ set. */
+extern int
+ iconveh_open (const char *to_codeset, const char *from_codeset,
+ iconveh_t *cdp);
+
+/* Close a conversion descriptor created by iconveh_open().
+ Return value: 0 if successful, otherwise -1 and errno set. */
+extern int
+ iconveh_close (const iconveh_t *cd);
+
/* Convert an entire string from one encoding to another, using iconv.
The original string is at [SRC,...,SRC+SRCLEN-1].
- CD is the conversion descriptor from FROMCODE to TOCODE, or (iconv_t)(-1) if
- the system does not support a direct conversion from FROMCODE to TOCODE.
- CD1 is the conversion descriptor from FROM_CODESET to UTF-8 (or
- (iconv_t)(-1) if FROM_CODESET is UTF-8).
- CD2 is the conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1)
- if TO_CODESET is UTF-8).
+ CD points to the conversion descriptor from FROMCODE to TOCODE, created by
+ the function iconveh_open().
If OFFSETS is not NULL, it should point to an array of SRCLEN integers; this
array is filled with offsets into the result, i.e. the character starting
at SRC[i] corresponds to the character starting at (*RESULTP)[OFFSETS[i]],
unchanged if no dynamic memory allocation was necessary. */
extern int
mem_cd_iconveh (const char *src, size_t srclen,
- iconv_t cd, iconv_t cd1, iconv_t cd2,
+ const iconveh_t *cd,
enum iconv_ilseq_handler handler,
size_t *offsets,
char **resultp, size_t *lengthp);
/* Convert an entire string from one encoding to another, using iconv.
The original string is the NUL-terminated string starting at SRC.
- CD is the conversion descriptor from FROMCODE to TOCODE, or (iconv_t)(-1) if
- the system does not support a direct conversion from FROMCODE to TOCODE.
+ CD points to the conversion descriptor from FROMCODE to TOCODE, created by
+ the function iconveh_open().
Both the "from" and the "to" encoding must use a single NUL byte at the end
of the string (i.e. not UCS-2, UCS-4, UTF-16, UTF-32).
- CD1 is the conversion descriptor from FROM_CODESET to UTF-8 (or
- (iconv_t)(-1) if FROM_CODESET is UTF-8).
- CD2 is the conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1)
- if TO_CODESET is UTF-8).
Allocate a malloced memory block for the result.
Return value: the freshly allocated resulting NUL-terminated string if
successful, otherwise NULL and errno set. */
extern char *
str_cd_iconveh (const char *src,
- iconv_t cd, iconv_t cd1, iconv_t cd2,
+ const iconveh_t *cd,
enum iconv_ilseq_handler handler);
#endif
#ifndef _GL_STRING_H
#define _GL_STRING_H
+/* NetBSD 5.0 mis-defines NULL. */
+#include <stddef.h>
#ifndef __attribute__
/* This feature is available in gcc versions 2.5 and later. */
/* Return a newly allocated copy of at most N bytes of STRING. */
#if @GNULIB_STRNDUP@
-# if ! @HAVE_STRNDUP@
+# if @REPLACE_STRNDUP@
# undef strndup
# define strndup rpl_strndup
# endif
-# if ! @HAVE_STRNDUP@ || ! @HAVE_DECL_STRNDUP@
+# if @REPLACE_STRNDUP@ || ! @HAVE_DECL_STRNDUP@
extern char *strndup (char const *__string, size_t __n);
# endif
#elif defined GNULIB_POSIXCHECK
See also strsep(). */
#if @GNULIB_STRTOK_R@
-# if ! @HAVE_DECL_STRTOK_R@
+# if @REPLACE_STRTOK_R@
+# undef strtok_r
+# define strtok_r rpl_strtok_r
+# elif @UNDEFINE_STRTOK_R@
+# undef strtok_r
+# endif
+# if ! @HAVE_DECL_STRTOK_R@ || @REPLACE_STRTOK_R@
extern char *strtok_r (char *restrict s, char const *restrict delim,
char **restrict save_ptr);
# endif
--- /dev/null
+/* Provide a sys/socket header file for systems lacking it (read: MinGW)
+ and for systems where it is incomplete.
+ Copyright (C) 2005-2009 Free Software Foundation, Inc.
+ Written by Simon Josefsson.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+/* This file is supposed to be used on platforms that lack <sys/socket.h>,
+ on platforms where <sys/socket.h> cannot be included standalone, and on
+ platforms where <sys/socket.h> does not provide all necessary definitions.
+ It is intended to provide definitions and prototypes needed by an
+ application. */
+
+#ifndef _GL_SYS_SOCKET_H
+
+#if @HAVE_SYS_SOCKET_H@
+
+# if __GNUC__ >= 3
+@PRAGMA_SYSTEM_HEADER@
+# endif
+
+/* On many platforms, <sys/socket.h> assumes prior inclusion of
+ <sys/types.h>. */
+# include <sys/types.h>
+
+/* The include_next requires a split double-inclusion guard. */
+# @INCLUDE_NEXT@ @NEXT_SYS_SOCKET_H@
+
+#endif
+
+#ifndef _GL_SYS_SOCKET_H
+#define _GL_SYS_SOCKET_H
+
+#if !@HAVE_SA_FAMILY_T@
+typedef unsigned short sa_family_t;
+#endif
+
+#if !@HAVE_STRUCT_SOCKADDR_STORAGE@
+# include <alignof.h>
+/* Code taken from glibc sysdeps/unix/sysv/linux/bits/socket.h on
+ 2009-05-08, licensed under LGPLv2.1+, plus portability fixes. */
+# define __ss_aligntype unsigned long int
+# define _SS_SIZE 256
+# define _SS_PADSIZE \
+ (_SS_SIZE - ((sizeof (sa_family_t) >= alignof (__ss_aligntype) \
+ ? sizeof (sa_family_t) \
+ : alignof (__ss_aligntype)) \
+ + sizeof (__ss_aligntype)))
+
+struct sockaddr_storage
+{
+ sa_family_t ss_family; /* Address family, etc. */
+ __ss_aligntype __ss_align; /* Force desired alignment. */
+ char __ss_padding[_SS_PADSIZE];
+};
+#endif
+
+#if @HAVE_SYS_SOCKET_H@
+
+/* A platform that has <sys/socket.h>. */
+
+/* For shutdown(). */
+# if !defined SHUT_RD
+# define SHUT_RD 0
+# endif
+# if !defined SHUT_WR
+# define SHUT_WR 1
+# endif
+# if !defined SHUT_RDWR
+# define SHUT_RDWR 2
+# endif
+
+#else
+
+# ifdef __CYGWIN__
+# error "Cygwin does have a sys/socket.h, doesn't it?!?"
+# endif
+
+/* A platform that lacks <sys/socket.h>.
+
+ Currently only MinGW is supported. See the gnulib manual regarding
+ Windows sockets. MinGW has the header files winsock2.h and
+ ws2tcpip.h that declare the sys/socket.h definitions we need. Note
+ that you can influence which definitions you get by setting the
+ WINVER symbol before including these two files. For example,
+ getaddrinfo is only available if _WIN32_WINNT >= 0x0501 (that
+ symbol is set indiriectly through WINVER). You can set this by
+ adding AC_DEFINE(WINVER, 0x0501) to configure.ac. Note that your
+ code may not run on older Windows releases then. My Windows 2000
+ box was not able to run the code, for example. The situation is
+ slightly confusing because:
+ http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/getaddrinfo_2.asp
+ suggests that getaddrinfo should be available on all Windows
+ releases. */
+
+
+# if @HAVE_WINSOCK2_H@
+# include <winsock2.h>
+# endif
+# if @HAVE_WS2TCPIP_H@
+# include <ws2tcpip.h>
+# endif
+
+/* For shutdown(). */
+# if !defined SHUT_RD && defined SD_RECEIVE
+# define SHUT_RD SD_RECEIVE
+# endif
+# if !defined SHUT_WR && defined SD_SEND
+# define SHUT_WR SD_SEND
+# endif
+# if !defined SHUT_RDWR && defined SD_BOTH
+# define SHUT_RDWR SD_BOTH
+# endif
+
+/* The definition of GL_LINK_WARNING is copied here. */
+
+# if @HAVE_WINSOCK2_H@
+/* Include headers needed by the emulation code. */
+# include <sys/types.h>
+# include <io.h>
+
+typedef int socklen_t;
+
+# endif
+
+# ifdef __cplusplus
+extern "C" {
+# endif
+
+# if @HAVE_WINSOCK2_H@
+
+/* Re-define FD_ISSET to avoid a WSA call while we are not using
+ network sockets. */
+static inline int
+rpl_fd_isset (SOCKET fd, fd_set * set)
+{
+ u_int i;
+ if (set == NULL)
+ return 0;
+
+ for (i = 0; i < set->fd_count; i++)
+ if (set->fd_array[i] == fd)
+ return 1;
+
+ return 0;
+}
+
+# undef FD_ISSET
+# define FD_ISSET(fd, set) rpl_fd_isset(fd, set)
+
+# endif
+
+/* Wrap everything else to use libc file descriptors for sockets. */
+
+# if @HAVE_WINSOCK2_H@ && !defined _GL_UNISTD_H
+# undef close
+# define close close_used_without_including_unistd_h
+# endif
+
+# if @HAVE_WINSOCK2_H@ && !defined _GL_UNISTD_H
+# undef gethostname
+# define gethostname gethostname_used_without_including_unistd_h
+# endif
+
+# if @GNULIB_SOCKET@
+# if @HAVE_WINSOCK2_H@
+# undef socket
+# define socket rpl_socket
+extern int rpl_socket (int, int, int protocol);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef socket
+# define socket socket_used_without_requesting_gnulib_module_socket
+# elif defined GNULIB_POSIXCHECK
+# undef socket
+# define socket(d,t,p) \
+ (GL_LINK_WARNING ("socket is not always POSIX compliant - " \
+ "use gnulib module socket for portability"), \
+ socket (d, t, p))
+# endif
+
+# if @GNULIB_CONNECT@
+# if @HAVE_WINSOCK2_H@
+# undef connect
+# define connect rpl_connect
+extern int rpl_connect (int, struct sockaddr *, int);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef connect
+# define connect socket_used_without_requesting_gnulib_module_connect
+# elif defined GNULIB_POSIXCHECK
+# undef connect
+# define connect(s,a,l) \
+ (GL_LINK_WARNING ("connect is not always POSIX compliant - " \
+ "use gnulib module connect for portability"), \
+ connect (s, a, l))
+# endif
+
+# if @GNULIB_ACCEPT@
+# if @HAVE_WINSOCK2_H@
+# undef accept
+# define accept rpl_accept
+extern int rpl_accept (int, struct sockaddr *, int *);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef accept
+# define accept accept_used_without_requesting_gnulib_module_accept
+# elif defined GNULIB_POSIXCHECK
+# undef accept
+# define accept(s,a,l) \
+ (GL_LINK_WARNING ("accept is not always POSIX compliant - " \
+ "use gnulib module accept for portability"), \
+ accept (s, a, l))
+# endif
+
+# if @GNULIB_BIND@
+# if @HAVE_WINSOCK2_H@
+# undef bind
+# define bind rpl_bind
+extern int rpl_bind (int, struct sockaddr *, int);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef bind
+# define bind bind_used_without_requesting_gnulib_module_bind
+# elif defined GNULIB_POSIXCHECK
+# undef bind
+# define bind(s,a,l) \
+ (GL_LINK_WARNING ("bind is not always POSIX compliant - " \
+ "use gnulib module bind for portability"), \
+ bind (s, a, l))
+# endif
+
+# if @GNULIB_GETPEERNAME@
+# if @HAVE_WINSOCK2_H@
+# undef getpeername
+# define getpeername rpl_getpeername
+extern int rpl_getpeername (int, struct sockaddr *, int *);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef getpeername
+# define getpeername getpeername_used_without_requesting_gnulib_module_getpeername
+# elif defined GNULIB_POSIXCHECK
+# undef getpeername
+# define getpeername(s,a,l) \
+ (GL_LINK_WARNING ("getpeername is not always POSIX compliant - " \
+ "use gnulib module getpeername for portability"), \
+ getpeername (s, a, l))
+# endif
+
+# if @GNULIB_GETSOCKNAME@
+# if @HAVE_WINSOCK2_H@
+# undef getsockname
+# define getsockname rpl_getsockname
+extern int rpl_getsockname (int, struct sockaddr *, int *);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef getsockname
+# define getsockname getsockname_used_without_requesting_gnulib_module_getsockname
+# elif defined GNULIB_POSIXCHECK
+# undef getsockname
+# define getsockname(s,a,l) \
+ (GL_LINK_WARNING ("getsockname is not always POSIX compliant - " \
+ "use gnulib module getsockname for portability"), \
+ getsockname (s, a, l))
+# endif
+
+# if @GNULIB_GETSOCKOPT@
+# if @HAVE_WINSOCK2_H@
+# undef getsockopt
+# define getsockopt rpl_getsockopt
+extern int rpl_getsockopt (int, int, int, void *, socklen_t *);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef getsockopt
+# define getsockopt getsockopt_used_without_requesting_gnulib_module_getsockopt
+# elif defined GNULIB_POSIXCHECK
+# undef getsockopt
+# define getsockopt(s,lvl,o,v,l) \
+ (GL_LINK_WARNING ("getsockopt is not always POSIX compliant - " \
+ "use gnulib module getsockopt for portability"), \
+ getsockopt (s, lvl, o, v, l))
+# endif
+
+# if @GNULIB_LISTEN@
+# if @HAVE_WINSOCK2_H@
+# undef listen
+# define listen rpl_listen
+extern int rpl_listen (int, int);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef listen
+# define listen listen_used_without_requesting_gnulib_module_listen
+# elif defined GNULIB_POSIXCHECK
+# undef listen
+# define listen(s,b) \
+ (GL_LINK_WARNING ("listen is not always POSIX compliant - " \
+ "use gnulib module listen for portability"), \
+ listen (s, b))
+# endif
+
+# if @GNULIB_RECV@
+# if @HAVE_WINSOCK2_H@
+# undef recv
+# define recv rpl_recv
+extern int rpl_recv (int, void *, int, int);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef recv
+# define recv recv_used_without_requesting_gnulib_module_recv
+# elif defined GNULIB_POSIXCHECK
+# undef recv
+# define recv(s,b,n,f) \
+ (GL_LINK_WARNING ("recv is not always POSIX compliant - " \
+ "use gnulib module recv for portability"), \
+ recv (s, b, n, f))
+# endif
+
+# if @GNULIB_SEND@
+# if @HAVE_WINSOCK2_H@
+# undef send
+# define send rpl_send
+extern int rpl_send (int, const void *, int, int);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef send
+# define send send_used_without_requesting_gnulib_module_send
+# elif defined GNULIB_POSIXCHECK
+# undef send
+# define send(s,b,n,f) \
+ (GL_LINK_WARNING ("send is not always POSIX compliant - " \
+ "use gnulib module send for portability"), \
+ send (s, b, n, f))
+# endif
+
+# if @GNULIB_RECVFROM@
+# if @HAVE_WINSOCK2_H@
+# undef recvfrom
+# define recvfrom rpl_recvfrom
+extern int rpl_recvfrom (int, void *, int, int, struct sockaddr *, int *);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef recvfrom
+# define recvfrom recvfrom_used_without_requesting_gnulib_module_recvfrom
+# elif defined GNULIB_POSIXCHECK
+# undef recvfrom
+# define recvfrom(s,b,n,f,a,l) \
+ (GL_LINK_WARNING ("recvfrom is not always POSIX compliant - " \
+ "use gnulib module recvfrom for portability"), \
+ recvfrom (s, b, n, f, a, l))
+# endif
+
+# if @GNULIB_SENDTO@
+# if @HAVE_WINSOCK2_H@
+# undef sendto
+# define sendto rpl_sendto
+extern int rpl_sendto (int, const void *, int, int, struct sockaddr *, int);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef sendto
+# define sendto sendto_used_without_requesting_gnulib_module_sendto
+# elif defined GNULIB_POSIXCHECK
+# undef sendto
+# define sendto(s,b,n,f,a,l) \
+ (GL_LINK_WARNING ("sendto is not always POSIX compliant - " \
+ "use gnulib module sendto for portability"), \
+ sendto (s, b, n, f, a, l))
+# endif
+
+# if @GNULIB_SETSOCKOPT@
+# if @HAVE_WINSOCK2_H@
+# undef setsockopt
+# define setsockopt rpl_setsockopt
+extern int rpl_setsockopt (int, int, int, const void *, socklen_t);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef setsockopt
+# define setsockopt setsockopt_used_without_requesting_gnulib_module_setsockopt
+# elif defined GNULIB_POSIXCHECK
+# undef setsockopt
+# define setsockopt(s,lvl,o,v,l) \
+ (GL_LINK_WARNING ("setsockopt is not always POSIX compliant - " \
+ "use gnulib module setsockopt for portability"), \
+ setsockopt (s, lvl, o, v, l))
+# endif
+
+# if @GNULIB_SHUTDOWN@
+# if @HAVE_WINSOCK2_H@
+# undef shutdown
+# define shutdown rpl_shutdown
+extern int rpl_shutdown (int, int);
+# endif
+# elif @HAVE_WINSOCK2_H@
+# undef shutdown
+# define shutdown shutdown_used_without_requesting_gnulib_module_shutdown
+# elif defined GNULIB_POSIXCHECK
+# undef shutdown
+# define shutdown(s,h) \
+ (GL_LINK_WARNING ("shutdown is not always POSIX compliant - " \
+ "use gnulib module shutdown for portability"), \
+ shutdown (s, h))
+# endif
+
+# if @HAVE_WINSOCK2_H@
+# undef select
+# define select select_used_without_including_sys_select_h
+# endif
+
+# ifdef __cplusplus
+}
+# endif
+
+#endif /* HAVE_SYS_SOCKET_H */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#if @GNULIB_ACCEPT4@
+/* Accept a connection on a socket, with specific opening flags.
+ The flags are a bitmask, possibly including O_CLOEXEC (defined in <fcntl.h>)
+ and O_TEXT, O_BINARY (defined in "binary-io.h").
+ See also the Linux man page at
+ <http://www.kernel.org/doc/man-pages/online/pages/man2/accept4.2.html>. */
+# if @HAVE_ACCEPT4@
+# define accept4 rpl_accept4
+# endif
+extern int accept4 (int sockfd, struct sockaddr *addr, socklen_t *addrlen,
+ int flags);
+#elif defined GNULIB_POSIXCHECK
+# undef accept4
+# define accept4(s,a,l,f) \
+ (GL_LINK_WARNING ("accept4 is unportable - " \
+ "use gnulib module accept4 for portability"), \
+ accept4 (s, a, l, f))
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _GL_SYS_SOCKET_H */
+#endif /* _GL_SYS_SOCKET_H */
--- /dev/null
+/* Provide a more complete sys/stat header file.
+ Copyright (C) 2005-2009 Free Software Foundation, Inc.
+
+ This program 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 2, or (at your option)
+ any later version.
+
+ This program 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 program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+/* Written by Eric Blake, Paul Eggert, and Jim Meyering. */
+
+/* This file is supposed to be used on platforms where <sys/stat.h> is
+ incomplete. It is intended to provide definitions and prototypes
+ needed by an application. Start with what the system provides. */
+
+#if __GNUC__ >= 3
+@PRAGMA_SYSTEM_HEADER@
+#endif
+
+#if defined __need_system_sys_stat_h
+/* Special invocation convention. */
+
+#@INCLUDE_NEXT@ @NEXT_SYS_STAT_H@
+
+#else
+/* Normal invocation convention. */
+
+#ifndef _GL_SYS_STAT_H
+
+/* Get nlink_t. */
+#include <sys/types.h>
+
+/* Get struct timespec. */
+#include <time.h>
+
+/* The include_next requires a split double-inclusion guard. */
+#@INCLUDE_NEXT@ @NEXT_SYS_STAT_H@
+
+#ifndef _GL_SYS_STAT_H
+#define _GL_SYS_STAT_H
+
+/* The definition of GL_LINK_WARNING is copied here. */
+
+/* Before doing "#define mkdir rpl_mkdir" below, we need to include all
+ headers that may declare mkdir(). */
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# include <io.h>
+#endif
+
+#ifndef S_IFMT
+# define S_IFMT 0170000
+#endif
+
+#if STAT_MACROS_BROKEN
+# undef S_ISBLK
+# undef S_ISCHR
+# undef S_ISDIR
+# undef S_ISFIFO
+# undef S_ISLNK
+# undef S_ISNAM
+# undef S_ISMPB
+# undef S_ISMPC
+# undef S_ISNWK
+# undef S_ISREG
+# undef S_ISSOCK
+#endif
+
+#ifndef S_ISBLK
+# ifdef S_IFBLK
+# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK)
+# else
+# define S_ISBLK(m) 0
+# endif
+#endif
+
+#ifndef S_ISCHR
+# ifdef S_IFCHR
+# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR)
+# else
+# define S_ISCHR(m) 0
+# endif
+#endif
+
+#ifndef S_ISDIR
+# ifdef S_IFDIR
+# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
+# else
+# define S_ISDIR(m) 0
+# endif
+#endif
+
+#ifndef S_ISDOOR /* Solaris 2.5 and up */
+# define S_ISDOOR(m) 0
+#endif
+
+#ifndef S_ISFIFO
+# ifdef S_IFIFO
+# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
+# else
+# define S_ISFIFO(m) 0
+# endif
+#endif
+
+#ifndef S_ISLNK
+# ifdef S_IFLNK
+# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
+# else
+# define S_ISLNK(m) 0
+# endif
+#endif
+
+#ifndef S_ISMPB /* V7 */
+# ifdef S_IFMPB
+# define S_ISMPB(m) (((m) & S_IFMT) == S_IFMPB)
+# define S_ISMPC(m) (((m) & S_IFMT) == S_IFMPC)
+# else
+# define S_ISMPB(m) 0
+# define S_ISMPC(m) 0
+# endif
+#endif
+
+#ifndef S_ISNAM /* Xenix */
+# ifdef S_IFNAM
+# define S_ISNAM(m) (((m) & S_IFMT) == S_IFNAM)
+# else
+# define S_ISNAM(m) 0
+# endif
+#endif
+
+#ifndef S_ISNWK /* HP/UX */
+# ifdef S_IFNWK
+# define S_ISNWK(m) (((m) & S_IFMT) == S_IFNWK)
+# else
+# define S_ISNWK(m) 0
+# endif
+#endif
+
+#ifndef S_ISPORT /* Solaris 10 and up */
+# define S_ISPORT(m) 0
+#endif
+
+#ifndef S_ISREG
+# ifdef S_IFREG
+# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
+# else
+# define S_ISREG(m) 0
+# endif
+#endif
+
+#ifndef S_ISSOCK
+# ifdef S_IFSOCK
+# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK)
+# else
+# define S_ISSOCK(m) 0
+# endif
+#endif
+
+
+#ifndef S_TYPEISMQ
+# define S_TYPEISMQ(p) 0
+#endif
+
+#ifndef S_TYPEISTMO
+# define S_TYPEISTMO(p) 0
+#endif
+
+
+#ifndef S_TYPEISSEM
+# ifdef S_INSEM
+# define S_TYPEISSEM(p) (S_ISNAM ((p)->st_mode) && (p)->st_rdev == S_INSEM)
+# else
+# define S_TYPEISSEM(p) 0
+# endif
+#endif
+
+#ifndef S_TYPEISSHM
+# ifdef S_INSHD
+# define S_TYPEISSHM(p) (S_ISNAM ((p)->st_mode) && (p)->st_rdev == S_INSHD)
+# else
+# define S_TYPEISSHM(p) 0
+# endif
+#endif
+
+/* high performance ("contiguous data") */
+#ifndef S_ISCTG
+# define S_ISCTG(p) 0
+#endif
+
+/* Cray DMF (data migration facility): off line, with data */
+#ifndef S_ISOFD
+# define S_ISOFD(p) 0
+#endif
+
+/* Cray DMF (data migration facility): off line, with no data */
+#ifndef S_ISOFL
+# define S_ISOFL(p) 0
+#endif
+
+/* 4.4BSD whiteout */
+#ifndef S_ISWHT
+# define S_ISWHT(m) 0
+#endif
+
+/* If any of the following are undefined,
+ define them to their de facto standard values. */
+#if !S_ISUID
+# define S_ISUID 04000
+#endif
+#if !S_ISGID
+# define S_ISGID 02000
+#endif
+
+/* S_ISVTX is a common extension to POSIX. */
+#ifndef S_ISVTX
+# define S_ISVTX 01000
+#endif
+
+#if !S_IRUSR && S_IREAD
+# define S_IRUSR S_IREAD
+#endif
+#if !S_IRUSR
+# define S_IRUSR 00400
+#endif
+#if !S_IRGRP
+# define S_IRGRP (S_IRUSR >> 3)
+#endif
+#if !S_IROTH
+# define S_IROTH (S_IRUSR >> 6)
+#endif
+
+#if !S_IWUSR && S_IWRITE
+# define S_IWUSR S_IWRITE
+#endif
+#if !S_IWUSR
+# define S_IWUSR 00200
+#endif
+#if !S_IWGRP
+# define S_IWGRP (S_IWUSR >> 3)
+#endif
+#if !S_IWOTH
+# define S_IWOTH (S_IWUSR >> 6)
+#endif
+
+#if !S_IXUSR && S_IEXEC
+# define S_IXUSR S_IEXEC
+#endif
+#if !S_IXUSR
+# define S_IXUSR 00100
+#endif
+#if !S_IXGRP
+# define S_IXGRP (S_IXUSR >> 3)
+#endif
+#if !S_IXOTH
+# define S_IXOTH (S_IXUSR >> 6)
+#endif
+
+#if !S_IRWXU
+# define S_IRWXU (S_IRUSR | S_IWUSR | S_IXUSR)
+#endif
+#if !S_IRWXG
+# define S_IRWXG (S_IRGRP | S_IWGRP | S_IXGRP)
+#endif
+#if !S_IRWXO
+# define S_IRWXO (S_IROTH | S_IWOTH | S_IXOTH)
+#endif
+
+/* S_IXUGO is a common extension to POSIX. */
+#if !S_IXUGO
+# define S_IXUGO (S_IXUSR | S_IXGRP | S_IXOTH)
+#endif
+
+#ifndef S_IRWXUGO
+# define S_IRWXUGO (S_IRWXU | S_IRWXG | S_IRWXO)
+#endif
+
+/* Macros for futimens and utimensat. */
+#ifndef UTIME_NOW
+# define UTIME_NOW (-1)
+# define UTIME_OMIT (-2)
+#endif
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+#if @GNULIB_FCHMODAT@
+# if !@HAVE_FCHMODAT@
+extern int fchmodat (int fd, char const *file, mode_t mode, int flag);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef fchmodat
+# define fchmodat(d,n,m,f) \
+ (GL_LINK_WARNING ("fchmodat is not portable - " \
+ "use gnulib module openat for portability"), \
+ fchmodat (d, n, m, f))
+#endif
+
+
+#if @REPLACE_FSTAT@
+# define fstat rpl_fstat
+extern int fstat (int fd, struct stat *buf);
+#endif
+
+
+#if @GNULIB_FSTATAT@
+# if @REPLACE_FSTATAT@
+# undef fstatat
+# define fstatat rpl_fstatat
+# endif
+# if !@HAVE_FSTATAT@ || @REPLACE_FSTATAT@
+extern int fstatat (int fd, char const *name, struct stat *st, int flags);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef fstatat
+# define fstatat(d,n,s,f) \
+ (GL_LINK_WARNING ("fstatat is not portable - " \
+ "use gnulib module openat for portability"), \
+ fstatat (d, n, s, f))
+#endif
+
+
+#if @GNULIB_FUTIMENS@
+# if @REPLACE_FUTIMENS@
+# undef futimens
+# define futimens rpl_futimens
+# endif
+# if !@HAVE_FUTIMENS@ || @REPLACE_FUTIMENS@
+extern int futimens (int fd, struct timespec const times[2]);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef futimens
+# define futimens(f,t) \
+ (GL_LINK_WARNING ("futimens is not portable - " \
+ "use gnulib module futimens for portability"), \
+ futimens (f, t))
+#endif
+
+
+#if @GNULIB_LCHMOD@
+/* Change the mode of FILENAME to MODE, without dereferencing it if FILENAME
+ denotes a symbolic link. */
+# if !@HAVE_LCHMOD@
+/* The lchmod replacement follows symbolic links. Callers should take
+ this into account; lchmod should be applied only to arguments that
+ are known to not be symbolic links. On hosts that lack lchmod,
+ this can lead to race conditions between the check and the
+ invocation of lchmod, but we know of no workarounds that are
+ reliable in general. You might try requesting support for lchmod
+ from your operating system supplier. */
+# define lchmod chmod
+# endif
+# if 0 /* assume already declared */
+extern int lchmod (const char *filename, mode_t mode);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef lchmod
+# define lchmod(f,m) \
+ (GL_LINK_WARNING ("lchmod is unportable - " \
+ "use gnulib module lchmod for portability"), \
+ lchmod (f, m))
+#endif
+
+
+#if @GNULIB_LSTAT@
+# if ! @HAVE_LSTAT@
+/* mingw does not support symlinks, therefore it does not have lstat. But
+ without links, stat does just fine. */
+# define lstat stat
+# elif @REPLACE_LSTAT@
+# undef lstat
+# define lstat rpl_lstat
+extern int rpl_lstat (const char *name, struct stat *buf);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef lstat
+# define lstat(p,b) \
+ (GL_LINK_WARNING ("lstat is unportable - " \
+ "use gnulib module lstat for portability"), \
+ lstat (p, b))
+#endif
+
+
+#if @REPLACE_MKDIR@
+# undef mkdir
+# define mkdir rpl_mkdir
+extern int mkdir (char const *name, mode_t mode);
+#else
+/* mingw's _mkdir() function has 1 argument, but we pass 2 arguments.
+ Additionally, it declares _mkdir (and depending on compile flags, an
+ alias mkdir), only in the nonstandard <io.h>, which is included above. */
+# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+
+static inline int
+rpl_mkdir (char const *name, mode_t mode)
+{
+ return _mkdir (name);
+}
+
+# define mkdir rpl_mkdir
+# endif
+#endif
+
+
+#if @GNULIB_MKDIRAT@
+# if !@HAVE_MKDIRAT@
+extern int mkdirat (int fd, char const *file, mode_t mode);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mkdirat
+# define mkdirat(d,n,m) \
+ (GL_LINK_WARNING ("mkdirat is not portable - " \
+ "use gnulib module openat for portability"), \
+ mkdirat (d, n, m))
+#endif
+
+
+#if @GNULIB_MKFIFO@
+# if @REPLACE_MKFIFO@
+# undef mkfifo
+# define mkfifo rpl_mkfifo
+# endif
+# if !@HAVE_MKFIFO@ || @REPLACE_MKFIFO@
+int mkfifo (char const *file, mode_t mode);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mkfifo
+# define mkfifo(n,m) \
+ (GL_LINK_WARNING ("mkfifo is not portable - " \
+ "use gnulib module mkfifo for portability"), \
+ mkfifo (n, m))
+#endif
+
+
+#if @GNULIB_MKFIFOAT@
+# if !@HAVE_MKFIFOAT@
+int mkfifoat (int fd, char const *file, mode_t mode);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mkfifoat
+# define mkfifoat(d,n,m) \
+ (GL_LINK_WARNING ("mkfifoat is not portable - " \
+ "use gnulib module mkfifoat for portability"), \
+ mkfifoat (d, n, m))
+#endif
+
+
+#if @GNULIB_MKNOD@
+# if @REPLACE_MKNOD@
+# undef mknod
+# define mknod rpl_mknod
+# endif
+# if !@HAVE_MKNOD@ || @REPLACE_MKNOD@
+int mknod (char const *file, mode_t mode, dev_t dev);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mknod
+# define mknod(n,m,d) \
+ (GL_LINK_WARNING ("mknod is not portable - " \
+ "use gnulib module mknod for portability"), \
+ mknod (n, m, d))
+#endif
+
+
+#if @GNULIB_MKNODAT@
+# if !@HAVE_MKNODAT@
+int mknodat (int fd, char const *file, mode_t mode, dev_t dev);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mknodat
+# define mknodat(f,n,m,d) \
+ (GL_LINK_WARNING ("mknodat is not portable - " \
+ "use gnulib module mkfifoat for portability"), \
+ mknodat (f, n, m, d))
+#endif
+
+
+#if @GNULIB_STAT@
+# if @REPLACE_STAT@
+/* We can't use the object-like #define stat rpl_stat, because of
+ struct stat. This means that rpl_stat will not be used if the user
+ does (stat)(a,b). Oh well. */
+# undef stat
+# ifdef _LARGE_FILES
+ /* With _LARGE_FILES defined, AIX (only) defines stat to stat64,
+ so we have to replace stat64() instead of stat(). */
+# define stat stat64
+# undef stat64
+# define stat64(name, st) rpl_stat (name, st)
+# else /* !_LARGE_FILES */
+# define stat(name, st) rpl_stat (name, st)
+# endif /* !_LARGE_FILES */
+extern int stat (const char *name, struct stat *buf);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef stat
+# define stat(p,b) \
+ (GL_LINK_WARNING ("stat is unportable - " \
+ "use gnulib module stat for portability"), \
+ stat (p, b))
+#endif
+
+
+#if @GNULIB_UTIMENSAT@
+# if @REPLACE_UTIMENSAT@
+# undef utimensat
+# define utimensat rpl_utimensat
+# endif
+# if !@HAVE_UTIMENSAT@ || @REPLACE_UTIMENSAT@
+ extern int utimensat (int fd, char const *name,
+ struct timespec const times[2], int flag);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef utimensat
+# define utimensat(d,n,t,f) \
+ (GL_LINK_WARNING ("utimensat is not portable - " \
+ "use gnulib module utimensat for portability"), \
+ utimensat (d, n, t, f))
+#endif
+
+
+#ifdef __cplusplus
+}
+#endif
+
+
+#endif /* _GL_SYS_STAT_H */
+#endif /* _GL_SYS_STAT_H */
+#endif
# @INCLUDE_NEXT@ @NEXT_TIME_H@
+/* NetBSD 5.0 mis-defines NULL. */
+#include <stddef.h>
+
# ifdef __cplusplus
extern "C" {
# endif
#ifndef _GL_UNISTD_H
#define _GL_UNISTD_H
+/* NetBSD 5.0 mis-defines NULL. Also get size_t. */
+#include <stddef.h>
+
/* mingw doesn't define the SEEK_* or *_FILENO macros in <unistd.h>. */
#if !(defined SEEK_CUR && defined SEEK_END && defined SEEK_SET)
# include <stdio.h>
/* mingw, BeOS, Haiku declare environ in <stdlib.h>, not in <unistd.h>. */
#include <stdlib.h>
-#if @GNULIB_WRITE@ && @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@
+#if ((@GNULIB_WRITE@ && @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@) \
+ || (@GNULIB_READLINK@ && (!@HAVE_READLINK@ || @REPLACE_READLINK@)) \
+ || (@GNULIB_READLINKAT@ && !@HAVE_READLINKAT@))
/* Get ssize_t. */
# include <sys/types.h>
#endif
+/* Get getopt(), optarg, optind, opterr, optopt. */
+#if @GNULIB_UNISTD_H_GETOPT@ && !defined _GL_SYSTEM_GETOPT
+# include <getopt.h>
+#endif
+
#if @GNULIB_GETHOSTNAME@
/* Get all possible declarations of gethostname(). */
# if @UNISTD_H_HAVE_WINSOCK2_H@
# define STDERR_FILENO 2
#endif
+/* Ensure *_OK macros exist. */
+#ifndef F_OK
+# define F_OK 0
+# define X_OK 1
+# define W_OK 2
+# define R_OK 4
+#endif
+
+
/* Declare overridden functions. */
#ifdef __cplusplus
#if @GNULIB_CHOWN@
# if @REPLACE_CHOWN@
-# ifndef REPLACE_CHOWN
-# define REPLACE_CHOWN 1
-# endif
-# if REPLACE_CHOWN
+# undef chown
+# define chown rpl_chown
+# endif
+# if !@HAVE_CHOWN@ || @REPLACE_CHOWN@
/* Change the owner of FILE to UID (if UID is not -1) and the group of FILE
to GID (if GID is not -1). Follow symbolic links.
Return 0 if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/chown.html>. */
-# define chown rpl_chown
extern int chown (const char *file, uid_t uid, gid_t gid);
-# endif
# endif
#elif defined GNULIB_POSIXCHECK
# undef chown
# define close rpl_close
extern int close (int);
# endif
-#elif @UNISTD_H_HAVE_WINSOCK2_H@
+#elif @UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS@
# undef close
# define close close_used_without_requesting_gnulib_module_close
#elif defined GNULIB_POSIXCHECK
#endif
+#if @REPLACE_DUP@
+# define dup rpl_dup
+extern int dup (int);
+#endif
+
+
#if @GNULIB_DUP2@
# if @REPLACE_DUP2@
# define dup2 rpl_dup2
#endif
+#if @GNULIB_DUP3@
+/* Copy the file descriptor OLDFD into file descriptor NEWFD, with the
+ specified flags.
+ The flags are a bitmask, possibly including O_CLOEXEC (defined in <fcntl.h>)
+ and O_TEXT, O_BINARY (defined in "binary-io.h").
+ Close NEWFD first if it is open.
+ Return newfd if successful, otherwise -1 and errno set.
+ See the Linux man page at
+ <http://www.kernel.org/doc/man-pages/online/pages/man2/dup3.2.html>. */
+# if @HAVE_DUP3@
+# define dup3 rpl_dup3
+# endif
+extern int dup3 (int oldfd, int newfd, int flags);
+#elif defined GNULIB_POSIXCHECK
+# undef dup3
+# define dup3(o,n,f) \
+ (GL_LINK_WARNING ("dup3 is unportable - " \
+ "use gnulib module dup3 for portability"), \
+ dup3 (o, n, f))
+#endif
+
+
#if @GNULIB_ENVIRON@
# if !@HAVE_DECL_ENVIRON@
/* Set of environment variables and values. An array of strings of the form
#if @GNULIB_EUIDACCESS@
# if !@HAVE_EUIDACCESS@
-/* Like access(), except that is uses the effective user id and group id of
+/* Like access(), except that it uses the effective user id and group id of
the current process. */
extern int euidaccess (const char *filename, int mode);
# endif
#endif
+#if @GNULIB_FACCESSAT@
+# if !@HAVE_FACCESSAT@
+int faccessat (int fd, char const *file, int mode, int flag);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef faccessat
+# define faccessat(d,n,m,f) \
+ (GL_LINK_WARNING ("faccessat is not portable - " \
+ "use gnulib module faccessat for portability"), \
+ faccessat (d, n, m, f))
+#endif
+
+
#if @GNULIB_FCHDIR@
# if @REPLACE_FCHDIR@
-
/* Change the process' current working directory to the directory on which
the given file descriptor is open.
Return 0 if successful, otherwise -1 and errno set.
<http://www.opengroup.org/susv3xsh/fchdir.html>. */
extern int fchdir (int /*fd*/);
-# define dup rpl_dup
-extern int dup (int);
-
-# if @REPLACE_DUP2@
-# undef dup2
-# endif
-# define dup2 rpl_dup2_fchdir
-extern int dup2 (int, int);
+/* Gnulib internal hooks needed to maintain the fchdir metadata. */
+extern int _gl_register_fd (int fd, const char *filename);
+extern void _gl_unregister_fd (int fd);
+extern int _gl_register_dup (int oldfd, int newfd);
+extern const char *_gl_directory_name (int fd);
# endif
#elif defined GNULIB_POSIXCHECK
#endif
+#if @GNULIB_FCHOWNAT@
+# if @REPLACE_FCHOWNAT@
+# undef fchownat
+# define fchownat rpl_fchownat
+# endif
+# if !@HAVE_FCHOWNAT@ || @REPLACE_FCHOWNAT@
+extern int fchownat (int fd, char const *file, uid_t owner, gid_t group, int flag);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef fchownat
+# define fchownat(d,n,o,g,f) \
+ (GL_LINK_WARNING ("fchownat is not portable - " \
+ "use gnulib module openat for portability"), \
+ fchownat (d, n, o, g, f))
+#endif
+
+
#if @GNULIB_FSYNC@
/* Synchronize changes to a file.
Return 0 if successful, otherwise -1 and errno set.
#if @GNULIB_GETDTABLESIZE@
# if !@HAVE_GETDTABLESIZE@
-/* Return the maximum number of file descriptors in the current process. */
+/* Return the maximum number of file descriptors in the current process.
+ In POSIX, this is same as sysconf (_SC_OPEN_MAX). */
extern int getdtablesize (void);
# endif
#elif defined GNULIB_POSIXCHECK
#endif
+#if @GNULIB_GETGROUPS@
+# if @REPLACE_GETGROUPS@
+# undef getgroups
+# define getgroups rpl_getgroups
+# endif
+# if !@HAVE_GETGROUPS@ || @REPLACE_GETGROUPS@
+/* Return the supplemental groups that the current process belongs to.
+ It is unspecified whether the effective group id is in the list.
+ If N is 0, return the group count; otherwise, N describes how many
+ entries are available in GROUPS. Return -1 and set errno if N is
+ not 0 and not large enough. Fails with ENOSYS on some systems. */
+int getgroups (int n, gid_t *groups);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef getgroups
+# define getgroups(n,g) \
+ (GL_LINK_WARNING ("getgroups is unportable - " \
+ "use gnulib module getgroups for portability"), \
+ getgroups (n, g))
+#endif
+
+
#if @GNULIB_GETHOSTNAME@
/* Return the standard host name of the machine.
WARNING! The host name may or may not be fully qualified.
See <http://www.opengroup.org/susv3xsh/getlogin.html>.
*/
# if !@HAVE_DECL_GETLOGIN_R@
-# include <stddef.h>
extern int getlogin_r (char *name, size_t size);
# endif
#elif defined GNULIB_POSIXCHECK
#if @GNULIB_LCHOWN@
# if @REPLACE_LCHOWN@
+# undef lchown
+# define lchown rpl_lchown
+# endif
+# if !@HAVE_LCHOWN@ || @REPLACE_LCHOWN@
/* Change the owner of FILE to UID (if UID is not -1) and the group of FILE
to GID (if GID is not -1). Do not follow symbolic links.
Return 0 if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/lchown.html>. */
-# define lchown rpl_lchown
extern int lchown (char const *file, uid_t owner, gid_t group);
# endif
#elif defined GNULIB_POSIXCHECK
#if @GNULIB_LINK@
+# if @REPLACE_LINK@
+# define link rpl_link
+# endif
/* Create a new hard link for an existing file.
Return 0 if successful, otherwise -1 and errno set.
See POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/link.html>. */
-# if !@HAVE_LINK@
+# if !@HAVE_LINK@ || @REPLACE_LINK@
extern int link (const char *path1, const char *path2);
# endif
#elif defined GNULIB_POSIXCHECK
link (path1, path2))
#endif
+#if @GNULIB_LINKAT@
+# if @REPLACE_LINKAT@
+# undef linkat
+# define linkat rpl_linkat
+# endif
+/* Create a new hard link for an existing file, relative to two
+ directories. FLAG controls whether symlinks are followed.
+ Return 0 if successful, otherwise -1 and errno set. */
+# if !@HAVE_LINKAT@ || @REPLACE_LINKAT@
+extern int linkat (int fd1, const char *path1, int fd2, const char *path2,
+ int flag);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef linkat
+# define link(f1,path1,f2,path2,f) \
+ (GL_LINK_WARNING ("linkat is unportable - " \
+ "use gnulib module linkat for portability"), \
+ linkat (f1, path1, f2, path2,f))
+#endif
#if @GNULIB_LSEEK@
# if @REPLACE_LSEEK@
#endif
+#if @GNULIB_PIPE2@
+/* Create a pipe, applying the given flags when opening the read-end of the
+ pipe and the write-end of the pipe.
+ The flags are a bitmask, possibly including O_CLOEXEC (defined in <fcntl.h>)
+ and O_TEXT, O_BINARY (defined in "binary-io.h").
+ Store the read-end as fd[0] and the write-end as fd[1].
+ Return 0 upon success, or -1 with errno set upon failure.
+ See also the Linux man page at
+ <http://www.kernel.org/doc/man-pages/online/pages/man2/pipe2.2.html>. */
+# if @HAVE_PIPE2@
+# define pipe2 rpl_pipe2
+# endif
+extern int pipe2 (int fd[2], int flags);
+#elif defined GNULIB_POSIXCHECK
+# undef pipe2
+# define pipe2(f,o) \
+ (GL_LINK_WARNING ("pipe2 is unportable - " \
+ "use gnulib module pipe2 for portability"), \
+ pipe2 (f, o))
+#endif
+
+
#if @GNULIB_READLINK@
+# if @REPLACE_READLINK@
+# define readlink rpl_readlink
+# endif
/* Read the contents of the symbolic link FILE and place the first BUFSIZE
bytes of it into BUF. Return the number of bytes placed into BUF if
successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/readlink.html>. */
-# if !@HAVE_READLINK@
-# include <stddef.h>
-extern int readlink (const char *file, char *buf, size_t bufsize);
+# if !@HAVE_READLINK@ || @REPLACE_READLINK@
+extern ssize_t readlink (const char *file, char *buf, size_t bufsize);
# endif
#elif defined GNULIB_POSIXCHECK
# undef readlink
#endif
+#if @GNULIB_READLINKAT@
+# if !@HAVE_READLINKAT@
+ssize_t readlinkat (int fd, char const *file, char *buf, size_t len);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef readlinkat
+# define readlinkat(d,n,b,l) \
+ (GL_LINK_WARNING ("readlinkat is not portable - " \
+ "use gnulib module symlinkat for portability"), \
+ readlinkat (d, n, b, l))
+#endif
+
+
+#if @GNULIB_RMDIR@
+# if @REPLACE_RMDIR@
+# define rmdir rpl_rmdir
+/* Remove the directory DIR. */
+extern int rmdir (char const *name);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef rmdir
+# define rmdir(n) \
+ (GL_LINK_WARNING ("rmdir is unportable - " \
+ "use gnulib module rmdir for portability"), \
+ rmdir (n))
+#endif
+
+
#if @GNULIB_SLEEP@
+# if @REPLACE_SLEEP@
+# undef sleep
+# define sleep rpl_sleep
+# endif
/* Pause the execution of the current thread for N seconds.
Returns the number of seconds left to sleep.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/sleep.html>. */
-# if !@HAVE_SLEEP@
+# if !@HAVE_SLEEP@ || @REPLACE_SLEEP@
extern unsigned int sleep (unsigned int n);
# endif
#elif defined GNULIB_POSIXCHECK
#endif
+#if @GNULIB_SYMLINK@
+# if @REPLACE_SYMLINK@
+# undef symlink
+# define symlink rpl_symlink
+# endif
+# if !@HAVE_SYMLINK@ || @REPLACE_SYMLINK@
+int symlink (char const *contents, char const *file);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef symlink
+# define symlink(c,n) \
+ (GL_LINK_WARNING ("symlink is not portable - " \
+ "use gnulib module symlink for portability"), \
+ symlink (c, n))
+#endif
+
+
+#if @GNULIB_SYMLINKAT@
+# if !@HAVE_SYMLINKAT@
+int symlinkat (char const *contents, int fd, char const *file);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef symlinkat
+# define symlinkat(c,d,n) \
+ (GL_LINK_WARNING ("symlinkat is not portable - " \
+ "use gnulib module symlinkat for portability"), \
+ symlinkat (c, d, n))
+#endif
+
+
+#if @GNULIB_UNLINK@
+# if @REPLACE_UNLINK@
+# undef unlink
+# define unlink rpl_unlink
+extern int unlink (char const *file);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef unlink
+# define unlink(n) \
+ (GL_LINK_WARNING ("unlink is not portable - " \
+ "use gnulib module unlink for portability"), \
+ unlink (n))
+#endif
+
+
+#if @GNULIB_UNLINKAT@
+# if @REPLACE_UNLINKAT@
+# undef unlinkat
+# define unlinkat rpl_unlinkat
+# endif
+# if !@HAVE_UNLINKAT@ || @REPLACE_UNLINKAT@
+extern int unlinkat (int fd, char const *file, int flag);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef unlinkat
+# define unlinkat(d,n,f) \
+ (GL_LINK_WARNING ("unlinkat is not portable - " \
+ "use gnulib module openat for portability"), \
+ unlinkat (d, n, f))
+#endif
+
+
+#if @GNULIB_USLEEP@
+# if @REPLACE_USLEEP@
+# undef usleep
+# define usleep rpl_usleep
+# endif
+# if !@HAVE_USLEEP@ || @REPLACE_USLEEP@
+/* Pause the execution of the current thread for N microseconds.
+ Returns 0 on completion, or -1 on range error.
+ See the POSIX:2001 specification
+ <http://www.opengroup.org/susv3xsh/sleep.html>. */
+extern int usleep (useconds_t n);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef usleep
+# define usleep(n) \
+ (GL_LINK_WARNING ("usleep is unportable - " \
+ "use gnulib module usleep for portability"), \
+ usleep (n))
+#endif
+
+
#if @GNULIB_WRITE@ && @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@
/* Write up to COUNT bytes starting at BUF to file descriptor FD.
See the POSIX:2001 specification
#endif
-#ifdef FCHDIR_REPLACEMENT
-/* gnulib internal function. */
-extern void _gl_unregister_fd (int fd);
-#endif
-
-
#ifdef __cplusplus
}
#endif
# ifndef decimal_point_char_defined
# define decimal_point_char_defined 1
static char
-decimal_point_char ()
+decimal_point_char (void)
{
const char *point;
/* Determine it in a multithread-safe way. We know nl_langinfo is
- multithread-safe on glibc systems, but is not required to be multithread-
- safe by POSIX. sprintf(), however, is multithread-safe. localeconv()
- is rarely multithread-safe. */
-# if HAVE_NL_LANGINFO && __GLIBC__
+ multithread-safe on glibc systems and MacOS X systems, but is not required
+ to be multithread-safe by POSIX. sprintf(), however, is multithread-safe.
+ localeconv() is rarely multithread-safe. */
+# if HAVE_NL_LANGINFO && (__GLIBC__ || (defined __APPLE__ && defined __MACH__))
point = nl_langinfo (RADIXCHAR);
# elif 1
char pointbuf[5];
characters = 0;
while (precision > 0)
{
- char buf[64]; /* Assume MB_CUR_MAX <= 64. */
+ char cbuf[64]; /* Assume MB_CUR_MAX <= 64. */
int count;
if (*arg_end == 0)
/* Found the terminating null wide character. */
break;
# if HAVE_WCRTOMB
- count = wcrtomb (buf, *arg_end, &state);
+ count = wcrtomb (cbuf, *arg_end, &state);
# else
- count = wctomb (buf, *arg_end);
+ count = wctomb (cbuf, *arg_end);
# endif
if (count < 0)
{
characters = 0;
for (;;)
{
- char buf[64]; /* Assume MB_CUR_MAX <= 64. */
+ char cbuf[64]; /* Assume MB_CUR_MAX <= 64. */
int count;
if (*arg_end == 0)
/* Found the terminating null wide character. */
break;
# if HAVE_WCRTOMB
- count = wcrtomb (buf, *arg_end, &state);
+ count = wcrtomb (cbuf, *arg_end, &state);
# else
- count = wctomb (buf, *arg_end);
+ count = wctomb (cbuf, *arg_end);
# endif
if (count < 0)
{
# endif
for (remaining = characters; remaining > 0; )
{
- char buf[64]; /* Assume MB_CUR_MAX <= 64. */
+ char cbuf[64]; /* Assume MB_CUR_MAX <= 64. */
int count;
if (*arg == 0)
abort ();
# if HAVE_WCRTOMB
- count = wcrtomb (buf, *arg, &state);
+ count = wcrtomb (cbuf, *arg, &state);
# else
- count = wctomb (buf, *arg);
+ count = wctomb (cbuf, *arg);
# endif
if (count <= 0)
/* Inconsistency. */
abort ();
- memcpy (tmpptr, buf, count);
+ memcpy (tmpptr, cbuf, count);
tmpptr += count;
arg++;
remaining -= count;
ENSURE_ALLOCATION (xsum (length, characters));
for (remaining = characters; remaining > 0; )
{
- char buf[64]; /* Assume MB_CUR_MAX <= 64. */
+ char cbuf[64]; /* Assume MB_CUR_MAX <= 64. */
int count;
if (*arg == 0)
abort ();
# if HAVE_WCRTOMB
- count = wcrtomb (buf, *arg, &state);
+ count = wcrtomb (cbuf, *arg, &state);
# else
- count = wctomb (buf, *arg);
+ count = wctomb (cbuf, *arg);
# endif
if (count <= 0)
/* Inconsistency. */
abort ();
- memcpy (result + length, buf, count);
+ memcpy (result + length, cbuf, count);
length += count;
arg++;
remaining -= count;
# endif
while (arg < arg_end)
{
- char buf[64]; /* Assume MB_CUR_MAX <= 64. */
+ char cbuf[64]; /* Assume MB_CUR_MAX <= 64. */
int count;
if (*arg == 0)
abort ();
# if HAVE_WCRTOMB
- count = wcrtomb (buf, *arg, &state);
+ count = wcrtomb (cbuf, *arg, &state);
# else
- count = wctomb (buf, *arg);
+ count = wctomb (cbuf, *arg);
# endif
if (count <= 0)
/* Inconsistency. */
abort ();
ENSURE_ALLOCATION (xsum (length, count));
- memcpy (result + length, buf, count);
+ memcpy (result + length, cbuf, count);
length += count;
arg++;
}
#undef TCHARS_PER_DCHAR
#undef SNPRINTF
#undef USE_SNPRINTF
+#undef DCHAR_SET
#undef DCHAR_CPY
#undef PRINTF_PARSE
#undef DIRECTIVES
-/* getpagesize emulation for systems where it cannot be done in a C macro.
-
- Copyright (C) 2007 Free Software Foundation, Inc.
+/* Variable with FSF copyright information, for version-etc.
+ Copyright (C) 1999-2006 Free Software Foundation, Inc.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. */
-/* Written by Bruno Haible and Martin Lambers. */
+/* Written by Jim Meyering. */
#include <config.h>
-/* Specification. */
-#include <unistd.h>
-
-/* This implementation is only for native Win32 systems. */
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
-
-# define WIN32_LEAN_AND_MEAN
-# include <windows.h>
+/* Specification. */
+#include "version-etc.h"
-int
-getpagesize (void)
-{
- SYSTEM_INFO system_info;
- GetSystemInfo (&system_info);
- return system_info.dwPageSize;
-}
+/* Default copyright goes to the FSF. */
-#endif
+const char version_etc_copyright[] =
+ /* Do *not* mark this string for translation. %s is a copyright
+ symbol suitable for this locale, and %d is the copyright
+ year. */
+ "Copyright %s %d Free Software Foundation, Inc.";
--- /dev/null
+/* Print --version and bug-reporting information in a consistent format.
+ Copyright (C) 1999-2009 Free Software Foundation, Inc.
+
+ This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Jim Meyering. */
+
+#include <config.h>
+
+/* Specification. */
+#include "version-etc.h"
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#if USE_UNLOCKED_IO
+# include "unlocked-io.h"
+#endif
+
+#include "gettext.h"
+#define _(msgid) gettext (msgid)
+
+enum { COPYRIGHT_YEAR = 2009 };
+
+/* The three functions below display the --version information the
+ standard way.
+
+ If COMMAND_NAME is NULL, the PACKAGE is assumed to be the name of
+ the program. The formats are therefore:
+
+ PACKAGE VERSION
+
+ or
+
+ COMMAND_NAME (PACKAGE) VERSION.
+
+ The functions differ in the way they are passed author names. */
+
+/* Display the --version information the standard way.
+
+ Author names are given in the array AUTHORS. N_AUTHORS is the
+ number of elements in the array. */
+void
+version_etc_arn (FILE *stream,
+ const char *command_name, const char *package,
+ const char *version,
+ const char * const * authors, size_t n_authors)
+{
+ if (command_name)
+ fprintf (stream, "%s (%s) %s\n", command_name, package, version);
+ else
+ fprintf (stream, "%s %s\n", package, version);
+
+#ifdef PACKAGE_PACKAGER
+# ifdef PACKAGE_PACKAGER_VERSION
+ fprintf (stream, _("Packaged by %s (%s)\n"), PACKAGE_PACKAGER,
+ PACKAGE_PACKAGER_VERSION);
+# else
+ fprintf (stream, _("Packaged by %s\n"), PACKAGE_PACKAGER);
+# endif
+#endif
+
+ /* TRANSLATORS: Translate "(C)" to the copyright symbol
+ (C-in-a-circle), if this symbol is available in the user's
+ locale. Otherwise, do not translate "(C)"; leave it as-is. */
+ fprintf (stream, version_etc_copyright, _("(C)"), COPYRIGHT_YEAR);
+
+ fputs (_("\
+\n\
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>.\n\
+This is free software: you are free to change and redistribute it.\n\
+There is NO WARRANTY, to the extent permitted by law.\n\
+\n\
+"),
+ stream);
+
+ switch (n_authors)
+ {
+ case 0:
+ /* The caller must provide at least one author name. */
+ abort ();
+ case 1:
+ /* TRANSLATORS: %s denotes an author name. */
+ fprintf (stream, _("Written by %s.\n"), authors[0]);
+ break;
+ case 2:
+ /* TRANSLATORS: Each %s denotes an author name. */
+ fprintf (stream, _("Written by %s and %s.\n"), authors[0], authors[1]);
+ break;
+ case 3:
+ /* TRANSLATORS: Each %s denotes an author name. */
+ fprintf (stream, _("Written by %s, %s, and %s.\n"),
+ authors[0], authors[1], authors[2]);
+ break;
+ case 4:
+ /* TRANSLATORS: Each %s denotes an author name.
+ You can use line breaks, estimating that each author name occupies
+ ca. 16 screen columns and that a screen line has ca. 80 columns. */
+ fprintf (stream, _("Written by %s, %s, %s,\nand %s.\n"),
+ authors[0], authors[1], authors[2], authors[3]);
+ break;
+ case 5:
+ /* TRANSLATORS: Each %s denotes an author name.
+ You can use line breaks, estimating that each author name occupies
+ ca. 16 screen columns and that a screen line has ca. 80 columns. */
+ fprintf (stream, _("Written by %s, %s, %s,\n%s, and %s.\n"),
+ authors[0], authors[1], authors[2], authors[3], authors[4]);
+ break;
+ case 6:
+ /* TRANSLATORS: Each %s denotes an author name.
+ You can use line breaks, estimating that each author name occupies
+ ca. 16 screen columns and that a screen line has ca. 80 columns. */
+ fprintf (stream, _("Written by %s, %s, %s,\n%s, %s, and %s.\n"),
+ authors[0], authors[1], authors[2], authors[3], authors[4],
+ authors[5]);
+ break;
+ case 7:
+ /* TRANSLATORS: Each %s denotes an author name.
+ You can use line breaks, estimating that each author name occupies
+ ca. 16 screen columns and that a screen line has ca. 80 columns. */
+ fprintf (stream, _("Written by %s, %s, %s,\n%s, %s, %s, and %s.\n"),
+ authors[0], authors[1], authors[2], authors[3], authors[4],
+ authors[5], authors[6]);
+ break;
+ case 8:
+ /* TRANSLATORS: Each %s denotes an author name.
+ You can use line breaks, estimating that each author name occupies
+ ca. 16 screen columns and that a screen line has ca. 80 columns. */
+ fprintf (stream, _("\
+Written by %s, %s, %s,\n%s, %s, %s, %s,\nand %s.\n"),
+ authors[0], authors[1], authors[2], authors[3], authors[4],
+ authors[5], authors[6], authors[7]);
+ break;
+ case 9:
+ /* TRANSLATORS: Each %s denotes an author name.
+ You can use line breaks, estimating that each author name occupies
+ ca. 16 screen columns and that a screen line has ca. 80 columns. */
+ fprintf (stream, _("\
+Written by %s, %s, %s,\n%s, %s, %s, %s,\n%s, and %s.\n"),
+ authors[0], authors[1], authors[2], authors[3], authors[4],
+ authors[5], authors[6], authors[7], authors[8]);
+ break;
+ default:
+ /* 10 or more authors. Use an abbreviation, since the human reader
+ will probably not want to read the entire list anyway. */
+ /* TRANSLATORS: Each %s denotes an author name.
+ You can use line breaks, estimating that each author name occupies
+ ca. 16 screen columns and that a screen line has ca. 80 columns. */
+ fprintf (stream, _("\
+Written by %s, %s, %s,\n%s, %s, %s, %s,\n%s, %s, and others.\n"),
+ authors[0], authors[1], authors[2], authors[3], authors[4],
+ authors[5], authors[6], authors[7], authors[8]);
+ break;
+ }
+}
+
+/* Display the --version information the standard way. See the initial
+ comment to this module, for more information.
+
+ Author names are given in the NULL-terminated array AUTHORS. */
+void
+version_etc_ar (FILE *stream,
+ const char *command_name, const char *package,
+ const char *version, const char * const * authors)
+{
+ size_t n_authors;
+
+ for (n_authors = 0; authors[n_authors]; n_authors++)
+ ;
+ version_etc_arn (stream, command_name, package, version, authors, n_authors);
+}
+
+/* Display the --version information the standard way. See the initial
+ comment to this module, for more information.
+
+ Author names are given in the NULL-terminated va_list AUTHORS. */
+void
+version_etc_va (FILE *stream,
+ const char *command_name, const char *package,
+ const char *version, va_list authors)
+{
+ size_t n_authors;
+ const char *authtab[10];
+
+ for (n_authors = 0;
+ n_authors < 10
+ && (authtab[n_authors] = va_arg (authors, const char *)) != NULL;
+ n_authors++)
+ ;
+ version_etc_arn (stream, command_name, package, version,
+ authtab, n_authors);
+}
+
+
+/* Display the --version information the standard way.
+
+ If COMMAND_NAME is NULL, the PACKAGE is assumed to be the name of
+ the program. The formats are therefore:
+
+ PACKAGE VERSION
+
+ or
+
+ COMMAND_NAME (PACKAGE) VERSION.
+
+ The authors names are passed as separate arguments, with an additional
+ NULL argument at the end. */
+void
+version_etc (FILE *stream,
+ const char *command_name, const char *package,
+ const char *version, /* const char *author1, ...*/ ...)
+{
+ va_list authors;
+
+ va_start (authors, version);
+ version_etc_va (stream, command_name, package, version, authors);
+ va_end (authors);
+}
+
+void
+emit_bug_reporting_address (void)
+{
+ /* TRANSLATORS: The placeholder indicates the bug-reporting address
+ for this package. Please add _another line_ saying
+ "Report translation bugs to <...>\n" with the address for translation
+ bugs (typically your translation team's web or email address). */
+ printf (_("\nReport bugs to: %s\n"), PACKAGE_BUGREPORT);
+#ifdef PACKAGE_PACKAGER_BUG_REPORTS
+ printf (_("Report %s bugs to: %s\n"), PACKAGE_PACKAGER,
+ PACKAGE_PACKAGER_BUG_REPORTS);
+#endif
+#ifdef PACKAGE_URL
+ printf (_("%s home page: <%s>\n"), PACKAGE_NAME, PACKAGE_URL);
+#else
+ printf (_("%s home page: <http://www.gnu.org/software/%s/>\n"),
+ PACKAGE_NAME, PACKAGE_TARNAME);
+#endif
+ fputs (_("General help using GNU software: <http://www.gnu.org/gethelp/>\n"),
+ stdout);
+}
--- /dev/null
+/* Print --version and bug-reporting information in a consistent format.
+ Copyright (C) 1999, 2003, 2005, 2009 Free Software Foundation, Inc.
+
+ This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Jim Meyering. */
+
+#ifndef VERSION_ETC_H
+# define VERSION_ETC_H 1
+
+# include <stdarg.h>
+# include <stdio.h>
+
+/* The `sentinel' attribute was added in gcc 4.0. */
+#ifndef ATTRIBUTE_SENTINEL
+# if 4 <= __GNUC__
+# define ATTRIBUTE_SENTINEL __attribute__ ((__sentinel__))
+# else
+# define ATTRIBUTE_SENTINEL /* empty */
+# endif
+#endif
+
+extern const char version_etc_copyright[];
+
+/* The three functions below display the --version information in the
+ standard way: command and package names, package version, followed
+ by a short GPLv3+ notice and a list of up to 10 author names.
+
+ If COMMAND_NAME is NULL, the PACKAGE is asumed to be the name of
+ the program. The formats are therefore:
+
+ PACKAGE VERSION
+
+ or
+
+ COMMAND_NAME (PACKAGE) VERSION.
+
+ The functions differ in the way they are passed author names: */
+
+/* N_AUTHORS names are supplied in array AUTHORS. */
+extern void version_etc_arn (FILE *stream,
+ const char *command_name, const char *package,
+ const char *version,
+ const char * const * authors, size_t n_authors);
+
+/* Names are passed in the NULL-terminated array AUTHORS. */
+extern void version_etc_ar (FILE *stream,
+ const char *command_name, const char *package,
+ const char *version, const char * const * authors);
+
+/* Names are passed in the NULL-terminated va_list. */
+extern void version_etc_va (FILE *stream,
+ const char *command_name, const char *package,
+ const char *version, va_list authors);
+
+/* Names are passed as separate arguments, with an additional
+ NULL argument at the end. */
+extern void version_etc (FILE *stream,
+ const char *command_name, const char *package,
+ const char *version,
+ /* const char *author1, ..., NULL */ ...)
+ ATTRIBUTE_SENTINEL;
+
+/* Display the usual `Report bugs to' stanza */
+extern void emit_bug_reporting_address (void);
+
+#endif /* VERSION_ETC_H */
/* POSIX compatible write() function.
- Copyright (C) 2008 Free Software Foundation, Inc.
+ Copyright (C) 2008-2009 Free Software Foundation, Inc.
Written by Bruno Haible <bruno@clisp.org>, 2008.
This program is free software: you can redistribute it and/or modify
if (ret < 0)
{
if (GetLastError () == ERROR_NO_DATA
- && GetFileType (_get_osfhandle (fd)) == FILE_TYPE_PIPE)
+ && GetFileType ((HANDLE) _get_osfhandle (fd)) == FILE_TYPE_PIPE)
{
/* Try to raise signal SIGPIPE. */
raise (SIGPIPE);
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
-#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
#include "libguile/guardians.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
+#include "libguile/i18n.h"
#include "libguile/init.h"
#include "libguile/ioext.h"
#include "libguile/rdelim.h"
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
-#include "libguile/objects.h"
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
#include "libguile/posix.h"
#include "libguile/print.h"
#include "libguile/procprop.h"
+#include "libguile/promises.h"
#include "libguile/properties.h"
#include "libguile/procs.h"
#include "libguile/r6rs-ports.h"
#include "libguile/symbols.h"
#include "libguile/tags.h"
#include "libguile/throw.h"
+#include "libguile/trees.h"
#include "libguile/uniform.h"
#include "libguile/validate.h"
#include "libguile/values.h"
ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
-lib_LTLIBRARIES = libguile.la \
- libguile-i18n-v-@LIBGUILE_I18N_MAJOR@.la
+lib_LTLIBRARIES = libguile.la
bin_PROGRAMS = guile
noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig
fluids.c \
fports.c \
frames.c \
- futures.c \
- gc-card.c \
- gc-freelist.c \
gc-malloc.c \
- gc-mark.c \
- gc-segment-table.c \
- gc-segment.c \
gc.c \
- gc_os_dep.c \
gdbint.c \
gettext.c \
generalized-arrays.c \
hash.c \
hashtab.c \
hooks.c \
+ i18n.c \
init.c \
inline.c \
instructions.c \
load.c \
macros.c \
mallocs.c \
+ memoize.c \
modules.c \
null-threads.c \
numbers.c \
objcodes.c \
- objects.c \
objprop.c \
options.c \
pairs.c \
procprop.c \
procs.c \
programs.c \
+ promises.c \
properties.c \
r6rs-ports.c \
random.c \
symbols.c \
threads.c \
throw.c \
+ trees.c \
uniform.c \
values.c \
variable.c \
vports.c \
weaks.c
-libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
-libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
- $(libguile_la_CFLAGS)
-libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \
- libguile.la $(gnulib_library)
-libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
- -module -L$(builddir) -lguile \
- -version-info @LIBGUILE_I18N_INTERFACE@
-
DOT_X_FILES = \
alist.x \
arbiters.x \
feature.x \
fluids.x \
fports.x \
- futures.x \
- gc-card.x \
gc-malloc.x \
- gc-mark.x \
- gc-segment-table.x \
- gc-segment.x \
gc.x \
gettext.x \
generalized-arrays.x \
load.x \
macros.x \
mallocs.x \
+ memoize.x \
modules.x \
numbers.x \
- objects.x \
objprop.x \
options.x \
pairs.x \
print.x \
procprop.x \
procs.x \
+ promises.x \
properties.x \
r6rs-ports.x \
random.x \
symbols.x \
threads.x \
throw.x \
+ trees.x \
uniform.x \
values.x \
variable.x \
feature.doc \
fluids.doc \
fports.doc \
- futures.doc \
- gc-card.doc \
gc-malloc.doc \
- gc-mark.doc \
- gc-segment-table.doc \
- gc-segment.doc \
gc.doc \
gettext.doc \
generalized-arrays.doc \
load.doc \
macros.doc \
mallocs.doc \
+ memoize.doc \
modules.doc \
numbers.doc \
- objects.doc \
objprop.doc \
options.doc \
pairs.doc \
print.doc \
procprop.doc \
procs.doc \
+ promises.doc \
properties.doc \
r6rs-ports.doc \
random.doc \
symbols.doc \
threads.doc \
throw.doc \
+ trees.doc \
uniform.doc \
values.doc \
variable.doc \
$(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
EXTRA_libguile_la_SOURCES = _scm.h \
- inet_aton.c memmove.c putenv.c strerror.c \
+ memmove.c strerror.c \
dynl.c regex-posix.c \
filesys.c posix.c net_db.c socket.c \
debug-malloc.c mkstemp.c \
## Perhaps we can deal with them normally once the merge seems to be
## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
- eval.i.c ieee-754.h \
- srfi-4.i.c srfi-14.i.c \
+ ieee-754.h \
+ srfi-4.i.c \
+ srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
- private-gc.h private-options.h
+ private-gc.h private-options.h
# vm instructions
noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
libguile_la_DEPENDENCIES = @LIBLOBJS@
-libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING)
-libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
+libguile_la_LIBADD = \
+ @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) \
+ $(LTLIBUNISTRING) $(LTLIBICONV)
+libguile_la_LDFLAGS = \
+ @LTLIBINTL@ $(INET_NTOP_LIB) $(INET_PTON_LIB) \
+ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ \
+ -export-dynamic -no-undefined \
+ $(GNU_LD_FLAGS)
if HAVE_LD_VERSION_SCRIPT
arrays.h \
async.h \
backtrace.h \
+ bdw-gc.h \
boolean.h \
bitvectors.h \
bytevectors.h \
fluids.h \
fports.h \
frames.h \
- futures.h \
gc.h \
gdb_interface.h \
gdbint.h \
load.h \
macros.h \
mallocs.h \
+ memoize.h \
modules.h \
net_db.h \
null-threads.h \
numbers.h \
objcodes.h \
- objects.h \
objprop.h \
options.h \
pairs.h \
procprop.h \
procs.h \
programs.h \
+ promises.h \
properties.h \
pthread-threads.h \
r6rs-ports.h \
tags.h \
threads.h \
throw.h \
+ trees.h \
validate.h \
uniform.h \
values.h \
@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_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
@echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp
@echo '#define SCM_BUILD_INFO { \' >> libpath.tmp
@echo ' { "infodir", "@infodir@" }, \' >> libpath.tmp
@echo ' { "mandir", "@mandir@" }, \' >> libpath.tmp
@echo ' { "includedir", "@includedir@" }, \' >> libpath.tmp
- @echo ' { "pkgdatadir", "@pkgdatadir@" }, \' >> libpath.tmp
- @echo ' { "pkglibdir", "@pkglibdir@" }, \' >> libpath.tmp
- @echo ' { "pkgincludedir", "@pkgincludedir@" }, \' \
+ @echo ' { "pkgdatadir", "$(pkgdatadir)" }, \' >> libpath.tmp
+ @echo ' { "pkglibdir", "$(pkglibdir)" }, \' >> libpath.tmp
+ @echo ' { "pkgincludedir", "$(pkgincludedir)" }, \' \
>> libpath.tmp
+ @echo ' { "extensionsdir", "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions" }, \' >> libpath.tmp
@echo ' { "guileversion", "@GUILE_VERSION@" }, \' >> libpath.tmp
@echo ' { "libguileinterface", "@LIBGUILE_INTERFACE@" }, \' \
>> libpath.tmp
* and then SCM_API marks them for export. */
#define SCM_INTERNAL extern
+/* The SCM_DEPRECATED macro is used in declarations of deprecated functions
+ * or variables. Defining `SCM_BUILDING_DEPRECATED_CODE' allows deprecated
+ * functions to be implemented in terms of deprecated functions, and allows
+ * deprecated functions to be referred to by `scm_c_define_gsubr ()'. */
+#if !defined (SCM_BUILDING_DEPRECATED_CODE) \
+ && defined (__GNUC__) && (__GNUC__ >= 3)
+# define SCM_DEPRECATED SCM_API __attribute__ ((__deprecated__))
+#else
+# define SCM_DEPRECATED SCM_API
+#endif
+
+/* The SCM_ALIGNED macro, when defined, can be used to instruct the compiler
+ * to honor the given alignment constraint. */
+#if defined __GNUC__
+# define SCM_ALIGNED(x) __attribute__ ((aligned (x)))
+#elif defined __INTEL_COMPILER
+# define SCM_ALIGNED(x) __declspec (align (x))
+#else
+/* Don't know how to align things. */
+# undef SCM_ALIGNED
+#endif
\f
/* {Supported Options}
/* #define GUILE_DEBUG_FREELIST */
-/* All the number support there is.
- */
-#define BIGNUMS
-
-/* GC should relinquish empty cons-pair arenas. */
-/* cmm:FIXME look at this after done mangling the GC */
-/* #define GC_FREE_SEGMENTS */
-
-/* Provide a scheme-accessible count-down timer that
- * generates a pseudo-interrupt.
- */
-#define TICKS
-
/* Use engineering notation when converting numbers strings?
*/
/* SCM_API is a macro prepended to all function and data definitions
which should be exported from libguile. */
-#if BUILDING_LIBGUILE && HAVE_VISIBILITY
+#if defined BUILDING_LIBGUILE && defined HAVE_VISIBILITY
# define SCM_API extern __attribute__((__visibility__("default")))
-#elif BUILDING_LIBGUILE && defined _MSC_VER
+#elif defined BUILDING_LIBGUILE && defined _MSC_VER
# define SCM_API __declspec(dllexport) extern
#elif defined _MSC_VER
# define SCM_API __declspec(dllimport) extern
#define SCM_T_INTMAX_MIN SCM_I_TYPE_MIN(scm_t_intmax,SCM_T_UINTMAX_MAX)
#define SCM_T_INTMAX_MAX SCM_I_TYPE_MAX(scm_t_intmax,SCM_T_UINTMAX_MAX)
+#define SCM_T_UINTPTR_MAX SCM_I_UTYPE_MAX(scm_t_uintptr)
+#define SCM_T_INTPTR_MIN SCM_I_TYPE_MIN(scm_t_intptr,SCM_T_UINTPTR_MAX)
+#define SCM_T_INTPTR_MAX SCM_I_TYPE_MAX(scm_t_intptr,SCM_T_UINTPTR_MAX)
+
#define SCM_I_SIZE_MAX SCM_I_UTYPE_MAX(size_t)
#define SCM_I_SSIZE_MIN SCM_I_TYPE_MIN(ssize_t,SCM_I_SIZE_MAX)
#define SCM_I_SSIZE_MAX SCM_I_TYPE_MAX(ssize_t,SCM_I_SIZE_MAX)
#define SCM_STACK_PTR(ptr) ((SCM_STACKITEM *) (void *) (ptr))
\f
-#define SCM_ASYNC_TICK /*fixme* should change names */ \
-do { \
- if (SCM_I_CURRENT_THREAD->pending_asyncs) \
- scm_async_click (); \
-} while (0)
+SCM_API void scm_async_tick (void);
+
+#ifdef BUILDING_LIBGUILE
+
+/* FIXME: should change names */
+# define SCM_ASYNC_TICK \
+ do \
+ { \
+ if (SCM_I_CURRENT_THREAD->pending_asyncs) \
+ scm_async_click (); \
+ } \
+ while (0)
+
+#else /* !BUILDING_LIBGUILE */
+
+# define SCM_ASYNC_TICK (scm_async_tick ())
+
+#endif /* !BUILDING_LIBGUILE */
/* Anthony Green writes:
#define SCM_C_INLINE_KEYWORD
#endif
+/* Handling thread-local storage (TLS). */
+
+#ifdef SCM_HAVE_THREAD_STORAGE_CLASS
+# define SCM_THREAD_LOCAL __thread
+#else
+# define SCM_THREAD_LOCAL
+#endif
+
#endif /* SCM___SCM_H */
/*
# include <config.h>
#endif
+/* The size of `scm_t_bits'. */
+#define SIZEOF_SCM_T_BITS SIZEOF_VOID_P
+
/* Undefine HAVE_STRUCT_TIMESPEC, because the libguile C code doesn't
need it anymore, and because on MinGW:
#include "libguile/variable.h"
#include "libguile/modules.h"
#include "libguile/inline.h"
+#include "libguile/strings.h"
#ifndef SCM_SYSCALL
#ifdef vms
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION D
+#define SCM_OBJCODE_MINOR_VERSION M
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
#define FUNC_NAME s_scm_try_arbiter
{
scm_t_bits old;
+ scm_t_bits *loc;
SCM_VALIDATE_SMOB (1, arb, arbiter);
- FETCH_STORE (old, * (scm_t_bits *) SCM_CELL_OBJECT_LOC(arb,0), SCM_LOCK_VAL);
+ loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0);
+ FETCH_STORE (old, *loc, SCM_LOCK_VAL);
return scm_from_bool (old == SCM_UNLOCK_VAL);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_release_arbiter
{
scm_t_bits old;
+ scm_t_bits *loc;
SCM_VALIDATE_SMOB (1, arb, arbiter);
- FETCH_STORE (old, *(scm_t_bits*)SCM_CELL_OBJECT_LOC(arb,0), SCM_UNLOCK_VAL);
+ loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0);
+ FETCH_STORE (old, *loc, SCM_UNLOCK_VAL);
return scm_from_bool (old == SCM_LOCK_VAL);
}
#undef FUNC_NAME
scm_init_arbiters ()
{
scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0);
- scm_set_smob_mark (scm_tc16_arbiter, scm_markcdr);
scm_set_smob_print (scm_tc16_arbiter, arbiter_print);
#include "libguile/arbiters.x"
}
scm_init_array_handle (void)
{
#define DEFINE_ARRAY_TYPE(tag, TAG) \
- scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] \
- = (scm_permanent_object (scm_from_locale_symbol (#tag)))
+ scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_locale_symbol (#tag)
scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
DEFINE_ARRAY_TYPE (a, CHAR);
#include "libguile/vectors.h"
#include "libguile/bitvectors.h"
#include "libguile/srfi-4.h"
-#include "libguile/dynwind.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
#include "libguile/array-map.h"
\f
-typedef struct
-{
- char *name;
- SCM sproc;
- int (*vproc) ();
-} ra_iproc;
-
-
-/* These tables are a kluge that will not scale well when more
- * vectorized subrs are added. It is tempting to steal some bits from
- * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
- * offset into a table of vectorized subrs.
- */
-
-static ra_iproc ra_rpsubrs[] =
-{
- {"=", SCM_UNDEFINED, scm_ra_eqp},
- {"<", SCM_UNDEFINED, scm_ra_lessp},
- {"<=", SCM_UNDEFINED, scm_ra_leqp},
- {">", SCM_UNDEFINED, scm_ra_grp},
- {">=", SCM_UNDEFINED, scm_ra_greqp},
- {0, 0, 0}
-};
-
-static ra_iproc ra_asubrs[] =
-{
- {"+", SCM_UNDEFINED, scm_ra_sum},
- {"-", SCM_UNDEFINED, scm_ra_difference},
- {"*", SCM_UNDEFINED, scm_ra_product},
- {"/", SCM_UNDEFINED, scm_ra_divide},
- {0, 0, 0}
-};
+/* The WHAT argument for `scm_gc_malloc ()' et al. */
+static const char indices_gc_hint[] = "array-indices";
#define GVREF scm_c_generalized_vector_ref
plvra = SCM_CDRLOC (*plvra);
}
- scm_dynwind_begin (0);
-
- vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra0));
- scm_dynwind_free (vinds);
+ vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
+ indices_gc_hint);
for (k = 0; k <= kmax; k++)
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
}
while (k >= 0);
- scm_dynwind_end ();
return 1;
}
}
unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null(ras))
- ras = scm_nullvect;
- else
- ras = scm_vector (ras);
+ ras = scm_vector (SCM_CDR (ras));
for (; i <= n; i++, i1 += inc1)
{
}
-static int
-ramap_dsubr (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra1)->lbnd + 1;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0))
- {
- default:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_call_1 (proc, GVREF (ra1, i1)));
- break;
- }
- return 1;
-}
-
-
-
-static int
-ramap_rp (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
- if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))))
- scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
-
- return 1;
-}
-
-
-
-static int
-ramap_1 (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
- else
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
- return 1;
-}
-
-
-
-static int
-ramap_2o (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null (ras))
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED));
- }
- else
- {
- SCM ra2 = SCM_CAR (ras);
- unsigned long i2 = SCM_I_ARRAY_BASE (ra2);
- long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
- ra2 = SCM_I_ARRAY_V (ra2);
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)));
- }
- return 1;
-}
-
-
-
-static int
-ramap_a (SCM ra0, SCM proc, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED));
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1)));
- }
- return 1;
-}
-
-
SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
SCM_SYMBOL (sym_b, "b");
SCM_VALIDATE_PROC (2, proc);
SCM_VALIDATE_REST_ARGUMENT (lra);
- switch (SCM_TYP7 (proc))
- {
- default:
- gencase:
- scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_1:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_2:
- if (! (scm_is_pair (lra) && scm_is_pair (SCM_CDR (lra))))
- SCM_WRONG_NUM_ARGS (); /* need 2 sources */
- goto subr_2o;
- case scm_tc7_subr_2o:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- subr_2o:
- scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_dsubr:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_rpsubr:
- {
- ra_iproc *p;
- if (!scm_is_typed_array (ra0, sym_b))
- goto gencase;
- scm_array_fill_x (ra0, SCM_BOOL_T);
- for (p = ra_rpsubrs; p->name; p++)
- if (scm_is_eq (proc, p->sproc))
- {
- while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
- {
- scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- case scm_tc7_asubr:
- if (scm_is_null (lra))
- {
- SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
- scm_array_fill_x (ra0, fill);
- }
- else
- {
- SCM tail, ra1 = SCM_CAR (lra);
- SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_V (ra0) : ra0);
- ra_iproc *p;
- /* Check to see if order might matter.
- This might be an argument for a separate
- SERIAL-ARRAY-MAP! */
- if (scm_is_eq (v0, ra1)
- || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
- if (!scm_is_eq (ra0, ra1)
- || (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0)))
- goto gencase;
- for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
- {
- ra1 = SCM_CAR (tail);
- if (scm_is_eq (v0, ra1)
- || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
- goto gencase;
- }
- for (p = ra_asubrs; p->name; p++)
- if (scm_is_eq (proc, p->sproc))
- {
- if (!scm_is_eq (ra0, SCM_CAR (lra)))
- scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
- lra = SCM_CDR (lra);
- while (1)
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
- if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
- return SCM_UNSPECIFIED;
- lra = SCM_CDR (lra);
- }
- }
- scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- if (SCM_NIMP (lra))
- for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
- scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
- }
- return SCM_UNSPECIFIED;
- }
+ scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null(ras))
- ras = scm_nullvect;
- else
- ras = scm_vector (ras);
+ ras = scm_vector (SCM_CDR (ras));
+
for (; i <= n; i++, i0 += inc0, i1 += inc1)
{
args = SCM_EOL;
if (kmax < 0)
return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
- scm_dynwind_begin (0);
-
- vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra));
- scm_dynwind_free (vinds);
+ vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
+ indices_gc_hint);
for (k = 0; k <= kmax; k++)
vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
}
while (k >= 0);
- scm_dynwind_end ();
return SCM_UNSPECIFIED;
}
else if (scm_is_generalized_vector (ra))
return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
}
-#if 0
-/* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
-SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
- (SCM ra0, SCM ra1),
+SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
+ (SCM ra0, SCM ra1, SCM rest),
"Return @code{#t} iff all arguments are arrays with the same\n"
"shape, the same type, and have corresponding elements which are\n"
"either @code{equal?} or @code{array-equal?}. This function\n"
"differs from @code{equal?} in that a one dimensional shared\n"
"array may be @var{array-equal?} but not @var{equal?} to a\n"
"vector or uniform vector.")
-#define FUNC_NAME s_scm_array_equal_p
-{
+#define FUNC_NAME s_scm_i_array_equal_p
+{
+ if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
+ return SCM_BOOL_T;
+
+ while (!scm_is_null (rest))
+ { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
+ return SCM_BOOL_F;
+ ra0 = ra1;
+ ra1 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_array_equal_p (ra0, ra1);
}
#undef FUNC_NAME
-#endif
-
-static char s_array_equal_p[] = "array-equal?";
SCM
}
-static void
-init_raprocs (ra_iproc *subra)
-{
- for (; subra->name; subra++)
- {
- SCM sym = scm_from_locale_symbol (subra->name);
- SCM var =
- scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
- if (var != SCM_BOOL_F)
- subra->sproc = SCM_VARIABLE_REF (var);
- else
- subra->sproc = SCM_BOOL_F;
- }
-}
-
-
void
scm_init_array_map (void)
{
- init_raprocs (ra_rpsubrs);
- init_raprocs (ra_asubrs);
- scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
#include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each);
scm_t_bits scm_i_tc16_array;
#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
+ (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
+ (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
scm_t_array_dim *s;
SCM ra;
scm_t_array_handle h;
- void *base;
+ void *elts;
size_t sz;
ra = scm_i_shap2ra (bounds);
scm_array_get_handle (ra, &h);
- base = scm_array_handle_uniform_writable_elements (&h);
- sz = scm_array_handle_uniform_element_size (&h);
+ elts = h.writable_elements;
+ sz = scm_array_handle_uniform_element_bit_size (&h);
scm_array_handle_release (&h);
- if (byte_len % sz)
- SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
- if (byte_len / sz != rlen)
- SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+ if (sz >= 8 && ((sz % 8) == 0))
+ {
+ if (byte_len % (sz / 8))
+ SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
+ if (byte_len / (sz / 8) != rlen)
+ SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+ }
+ else if (sz < 8)
+ {
+ /* byte_len ?= ceil (rlen * sz / 8) */
+ if (byte_len != (rlen * sz + 7) / 8)
+ SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+ }
+ else
+ /* an internal guile error, really */
+ SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
- memcpy (base, bytes, byte_len);
+ memcpy (elts, bytes, byte_len);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
}
-static SCM
-array_mark (SCM ptr)
-{
- return SCM_I_ARRAY_V (ptr);
-}
-
-static size_t
-array_free (SCM ptr)
-{
- scm_gc_free (SCM_I_ARRAY_MEM (ptr),
- (sizeof (scm_i_t_array)
- + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
- "array");
- return 0;
-}
-
static SCM
array_handle_ref (scm_t_array_handle *h, size_t pos)
{
h->base = SCM_I_ARRAY_BASE (array);
}
-SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array),
+ SCM_SMOB_TYPE_MASK,
array_handle_ref, array_handle_set,
array_get_handle);
scm_init_arrays ()
{
scm_i_tc16_array = scm_make_smob_type ("array", 0);
- scm_set_smob_mark (scm_i_tc16_array, array_mark);
- scm_set_smob_free (scm_i_tc16_array, array_free);
scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);
SCM_API scm_t_bits scm_i_tc16_array;
-#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16)
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
-#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17))
-#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
+#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_SMOB_FLAGS (x)>>1))
+#define SCM_I_ARRAY_CONTP(x) (SCM_SMOB_FLAGS(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
-#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
+#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_SMOB_DATA_1 (a))
#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
#define SCM_I_ARRAY_DIMS(a) \
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009 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
# include <config.h>
#endif
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include <signal.h>
#include "libguile/_scm.h"
#include "libguile/eval.h"
#define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
#define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")
-#define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16)
-#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16)))
-#define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X)
+#define ASYNC_GOT_IT(X) (SCM_SMOB_FLAGS (X))
+#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V))))
+#define ASYNC_THUNK(X) SCM_SMOB_OBJECT_1 (X)
-static SCM
-async_gc_mark (SCM obj)
-{
- return ASYNC_THUNK (obj);
-}
SCM_DEFINE (scm_async, "async", 1, 0, 0,
(SCM thunk),
scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
}
+\f
+/* These are function variants of the same-named macros (uppercase) for use
+ outside of libguile. This is so that `SCM_I_CURRENT_THREAD', which may
+ reside in TLS, is not accessed from outside of libguile. It thus allows
+ libguile to be built with the "local-dynamic" TLS model. */
+
+void
+scm_critical_section_start (void)
+{
+ SCM_CRITICAL_SECTION_START;
+}
+
+void
+scm_critical_section_end (void)
+{
+ SCM_CRITICAL_SECTION_END;
+}
+
+void
+scm_async_tick (void)
+{
+ SCM_ASYNC_TICK;
+}
\f
void
scm_init_async ()
{
- scm_asyncs = SCM_EOL;
tc16_async = scm_make_smob_type ("async", 0);
- scm_set_smob_mark (tc16_async, async_gc_mark);
#include "libguile/async.x"
}
#ifndef SCM_ASYNC_H
#define SCM_ASYNC_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009 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
\f
-#define scm_mask_ints (SCM_I_CURRENT_THREAD->block_asyncs != 0)
-
-\f
-
SCM_API void scm_async_click (void);
SCM_API void scm_switch (void);
SCM_API SCM scm_async (SCM thunk);
the manual.
*/
-/* Defined in threads.c. scm_i_critical_section_level is only used
- for error checking and will go away eventually. */
-extern scm_i_pthread_mutex_t scm_i_critical_section_mutex;
-extern int scm_i_critical_section_level;
+/* Defined in threads.c. */
+SCM_INTERNAL scm_i_pthread_mutex_t scm_i_critical_section_mutex;
+
+SCM_API void scm_critical_section_start (void);
+SCM_API void scm_critical_section_end (void);
-#define SCM_CRITICAL_SECTION_START \
- do { \
- scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex);\
- SCM_I_CURRENT_THREAD->block_asyncs++; \
- scm_i_critical_section_level++; \
+#ifdef BUILDING_LIBGUILE
+
+# define SCM_CRITICAL_SECTION_START \
+ do { \
+ scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex); \
+ SCM_I_CURRENT_THREAD->block_asyncs++; \
+ SCM_I_CURRENT_THREAD->critical_section_level++; \
} while (0)
-#define SCM_CRITICAL_SECTION_END \
- do { \
- scm_i_critical_section_level--; \
- SCM_I_CURRENT_THREAD->block_asyncs--; \
+# define SCM_CRITICAL_SECTION_END \
+ do { \
+ SCM_I_CURRENT_THREAD->critical_section_level--; \
+ SCM_I_CURRENT_THREAD->block_asyncs--; \
scm_i_pthread_mutex_unlock (&scm_i_critical_section_mutex); \
- scm_async_click (); \
+ scm_async_click (); \
} while (0)
+#else /* !BUILDING_LIBGUILE */
+
+# define SCM_CRITICAL_SECTION_START scm_critical_section_start ()
+# define SCM_CRITICAL_SECTION_END scm_critical_section_end ()
+
+#endif /* !BUILDING_LIBGUILE */
+
SCM_INTERNAL void scm_init_async (void);
#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_API SCM scm_system_async (SCM thunk);
-SCM_API SCM scm_unmask_signals (void);
-SCM_API SCM scm_mask_signals (void);
+SCM_DEPRECATED SCM scm_system_async (SCM thunk);
+SCM_DEPRECATED SCM scm_unmask_signals (void);
+SCM_DEPRECATED SCM scm_mask_signals (void);
#endif
/* Printing of backtraces and error messages
- * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation
+ * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/dynwind.h"
+#include "libguile/frames.h"
#include "libguile/validate.h"
#include "libguile/lang.h"
static void
display_header (SCM source, SCM port)
{
- if (SCM_MEMOIZEDP (source))
- {
- SCM fname = scm_source_property (source, scm_sym_filename);
- SCM line = scm_source_property (source, scm_sym_line);
- SCM col = scm_source_property (source, scm_sym_column);
-
- /* Dirk:FIXME:: Maybe we should store the _port_ rather than the
- * filename with the source properties? Then we could in case of
- * non-file ports give at least some more details than just
- * "<unnamed port>". */
- if (scm_is_true (fname))
- scm_prin1 (fname, port, 0);
- else
- scm_puts ("<unnamed port>", port);
-
- if (scm_is_true (line) && scm_is_true (col))
- {
- scm_putc (':', port);
- scm_intprint (scm_to_long (line) + 1, 10, port);
- scm_putc (':', port);
- scm_intprint (scm_to_long (col) + 1, 10, port);
- }
- }
- else
- scm_puts ("ERROR", port);
+ scm_puts ("ERROR", port);
scm_puts (": ", port);
}
pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH;
if (scm_is_symbol (pname) || scm_is_string (pname))
{
- if (SCM_FRAMEP (frame)
- && SCM_FRAME_EVAL_ARGS_P (frame))
- scm_puts ("While evaluating arguments to ", port);
- else
- scm_puts ("In procedure ", port);
+ scm_puts ("In procedure ", port);
scm_iprin1 (pname, port, pstate);
- if (SCM_MEMOIZEDP (source))
- {
- scm_puts (" in expression ", port);
- pstate->writingp = 1;
- scm_iprin1 (scm_i_unmemoize_expr (source), port, pstate);
- }
- }
- else if (SCM_MEMOIZEDP (source))
- {
- scm_puts ("In expression ", port);
- pstate->writingp = 1;
- scm_iprin1 (scm_i_unmemoize_expr (source), port, pstate);
}
scm_puts (":\n", port);
scm_free_print_state (print_state);
{
SCM current_frame = SCM_BOOL_F;
SCM source = SCM_BOOL_F;
- SCM prev_frame = SCM_BOOL_F;
SCM pname = a->subr;
- if (scm_debug_mode_p
- && SCM_STACKP (a->stack)
- && SCM_STACK_LENGTH (a->stack) > 0)
- {
- current_frame = scm_stack_ref (a->stack, SCM_INUM0);
- source = SCM_FRAME_SOURCE (current_frame);
- prev_frame = SCM_FRAME_PREV (current_frame);
- if (!SCM_MEMOIZEDP (source) && scm_is_true (prev_frame))
- source = SCM_FRAME_SOURCE (prev_frame);
- if (!scm_is_symbol (pname)
- && !scm_is_string (pname)
- && SCM_FRAME_PROC_P (current_frame)
- && scm_is_true (scm_procedure_p (SCM_FRAME_PROC (current_frame))))
- pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
- }
- if (scm_is_symbol (pname) || scm_is_string (pname) || SCM_MEMOIZEDP (source))
+ if (scm_is_symbol (pname) || scm_is_string (pname))
{
display_header (source, a->port);
display_expression (current_frame, pname, source, a->port);
static void
display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
- SCM proc = SCM_FRAME_PROC (frame);
+ SCM proc = scm_frame_procedure (frame);
SCM name = (scm_is_true (scm_procedure_p (proc))
? scm_procedure_name (proc)
: SCM_BOOL_F);
display_frame_expr ("[",
scm_cons (scm_is_true (name) ? name : proc,
- SCM_FRAME_ARGS (frame)),
- SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
+ scm_frame_arguments (frame)),
+ "]",
indentation,
sport,
port,
if (SCM_UNBNDP (indent))
indent = SCM_INUM0;
- if (SCM_FRAME_PROC_P (frame))
- /* Display an application. */
- {
- SCM sport, print_state;
- scm_print_state *pstate;
+ /* Display an application. */
+ {
+ SCM sport, print_state;
+ scm_print_state *pstate;
- /* Create a string port used for adaptation of printing parameters. */
- sport = scm_mkstrport (SCM_INUM0,
- scm_make_string (scm_from_int (240),
- SCM_UNDEFINED),
- SCM_OPN | SCM_WRTNG,
- FUNC_NAME);
-
- /* Create a print state for printing of frames. */
- print_state = scm_make_print_state ();
- pstate = SCM_PRINT_STATE (print_state);
- pstate->writingp = 1;
- pstate->fancyp = 1;
+ /* Create a string port used for adaptation of printing parameters. */
+ sport = scm_mkstrport (SCM_INUM0,
+ scm_make_string (scm_from_int (240),
+ SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ FUNC_NAME);
+
+ /* Create a print state for printing of frames. */
+ print_state = scm_make_print_state ();
+ pstate = SCM_PRINT_STATE (print_state);
+ pstate->writingp = 1;
+ pstate->fancyp = 1;
- display_application (frame, scm_to_int (indent), sport, port, pstate);
- return SCM_BOOL_T;
- }
- else
- return SCM_BOOL_F;
+ display_application (frame, scm_to_int (indent), sport, port, pstate);
+ return SCM_BOOL_T;
+ }
}
#undef FUNC_NAME
static void
display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
{
- SCM source = SCM_FRAME_SOURCE (frame);
+ SCM source = scm_frame_source (frame);
*file = *line = SCM_BOOL_F;
- if (SCM_MEMOIZEDP (source))
- {
- *file = scm_source_property (source, scm_sym_filename);
- *line = scm_source_property (source, scm_sym_line);
- }
- else if (scm_is_pair (source)
- && scm_is_pair (scm_cdr (source))
- && scm_is_pair (scm_cddr (source))
- && !scm_is_pair (scm_cdddr (source)))
+ if (scm_is_pair (source)
+ && scm_is_pair (scm_cdr (source))
+ && scm_is_pair (scm_cddr (source))
+ && !scm_is_pair (scm_cdddr (source)))
{
/* (addr . (filename . (line . column))), from vm compilation */
*file = scm_cadr (source);
display_backtrace_get_file_line (frame, &file, &line);
- if (scm_is_eq (file, *last_file))
+ if (scm_is_true (scm_equal_p (file, *last_file)))
return;
*last_file = file;
}
static void
-display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate)
+display_frame (SCM frame, int n, int nfield, int indentation,
+ SCM sport, SCM port, scm_print_state *pstate)
{
- int n, i, j;
-
- /* Announce missing frames? */
- if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
- {
- indent (nfield + 1 + indentation, port);
- scm_puts ("...\n", port);
- }
+ int i, j;
/* display file name and line number */
if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME)))
display_backtrace_file_and_line (frame, port, pstate);
/* Check size of frame number. */
- n = SCM_FRAME_NUMBER (frame);
for (i = 0, j = n; j > 0; ++i) j /= 10;
/* Number indentation. */
/* Frame number. */
scm_iprin1 (scm_from_int (n), port, pstate);
- /* Real frame marker */
- scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
-
/* Indentation. */
indent (indentation, port);
- if (SCM_FRAME_PROC_P (frame))
- /* Display an application. */
- display_application (frame, nfield + 1 + indentation, sport, port, pstate);
- else
- /* Display a special form. */
- {
- SCM source = SCM_FRAME_SOURCE (frame);
- SCM copy = (scm_is_pair (source)
- ? scm_source_property (source, scm_sym_copy)
- : SCM_BOOL_F);
- SCM umcopy = (SCM_MEMOIZEDP (source)
- ? scm_i_unmemoize_expr (source)
- : SCM_BOOL_F);
- display_frame_expr ("(",
- scm_is_pair (copy) ? copy : umcopy,
- ")",
- nfield + 1 + indentation,
- sport,
- port,
- pstate);
- }
+ /* Display an application. */
+ display_application (frame, nfield + 1 + indentation, sport, port, pstate);
scm_putc ('\n', port);
-
- /* Announce missing frames? */
- if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
- {
- indent (nfield + 1 + indentation, port);
- scm_puts ("...\n", port);
- }
}
struct display_backtrace_args {
pstate->highlight_objects = a->highlight_objects;
/* First find out if it's reasonable to do indentation. */
- if (SCM_BACKWARDS_P)
- indent_p = 0;
- else
- {
- unsigned int j;
-
- indent_p = 1;
- frame = scm_stack_ref (a->stack, scm_from_int (beg));
- for (i = 0, j = 0; i < n; ++i)
- {
- if (SCM_FRAME_REAL_P (frame))
- ++j;
- if (j > SCM_BACKTRACE_INDENT)
- {
- indent_p = 0;
- break;
- }
- frame = (SCM_BACKWARDS_P
- ? SCM_FRAME_PREV (frame)
- : SCM_FRAME_NEXT (frame));
- }
- }
+ indent_p = 0;
/* Determine size of frame number field. */
- j = SCM_FRAME_NUMBER (scm_stack_ref (a->stack, scm_from_int (end)));
+ j = end;
for (i = 0; j > 0; ++i) j /= 10;
nfield = i ? i : 1;
/* Print frames. */
- frame = scm_stack_ref (a->stack, scm_from_int (beg));
indentation = 1;
last_file = SCM_UNDEFINED;
- for (i = 0; i < n; ++i)
+ if (SCM_BACKWARDS_P)
+ end++;
+ else
+ end--;
+ for (i = beg; i != end; SCM_BACKWARDS_P ? ++i : --i)
{
+ frame = scm_stack_ref (a->stack, scm_from_int (i));
if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
display_backtrace_file (frame, &last_file, a->port, pstate);
-
- display_frame (frame, nfield, indentation, sport, a->port, pstate);
- if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
- ++indentation;
- frame = (SCM_BACKWARDS_P ?
- SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame));
+ display_frame (frame, i, nfield, indentation, sport, a->port, pstate);
}
scm_remember_upto_here_1 (print_state);
--- /dev/null
+#ifndef SCM_BDW_GC_H
+#define SCM_BDW_GC_H
+
+/* Copyright (C) 2006, 2008, 2009 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
+ */
+
+/* Correct header inclusion. */
+
+#include "libguile/scmconfig.h"
+
+#ifdef SCM_USE_PTHREAD_THREADS
+
+/* When pthreads are used, let `libgc' know about it and redirect allocation
+ calls such as `GC_MALLOC ()' to (contention-free, faster) thread-local
+ allocation. */
+
+# define GC_THREADS 1
+# define GC_REDIRECT_TO_LOCAL 1
+
+#endif
+
+#include <gc/gc.h>
+
+#if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7)))
+/* This was needed with `libgc' 6.x. */
+# include <gc/gc_local_alloc.h>
+#endif
+
+#if (defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7)
+/* This type was provided by `libgc' 6.x. */
+typedef void *GC_PTR;
+#endif
+
+
+/* Return true if PTR points to the heap. */
+#define SCM_I_IS_POINTER_TO_THE_HEAP(ptr) \
+ (GC_base (ptr) != NULL)
+
+/* Register a disappearing link for the object pointed to by OBJ such that
+ the pointer pointed to be LINK is cleared when OBJ is reclaimed. Do so
+ only if OBJ actually points to the heap. See
+ http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2563
+ for details. */
+#define SCM_I_REGISTER_DISAPPEARING_LINK(link, obj) \
+ ((SCM_I_IS_POINTER_TO_THE_HEAP (obj)) \
+ ? GC_GENERAL_REGISTER_DISAPPEARING_LINK ((link), (obj)) \
+ : 0)
+
+
+#endif /* SCM_BDW_GC_H */
#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
-static size_t
-bitvector_free (SCM vec)
-{
- scm_gc_free (BITVECTOR_BITS (vec),
- sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32),
- "bitvector");
- return 0;
-}
-
static int
bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
{
scm_t_uint32 *bits;
SCM res;
- bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
- "bitvector");
+ bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len,
+ "bitvector");
SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
if (!SCM_UNBNDP (fill))
h->elements = h->writable_elements = BITVECTOR_BITS (bv);
}
-SCM_ARRAY_IMPLEMENTATION (scm_tc16_bitvector, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_bitvector),
+ SCM_SMOB_TYPE_MASK,
bitvector_handle_ref, bitvector_handle_set,
bitvector_get_handle);
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector);
scm_init_bitvectors ()
{
scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
- scm_set_smob_free (scm_tc16_bitvector, bitvector_free);
scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
-/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008, 2009 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
#include "libguile/lang.h"
#include "libguile/tags.h"
+#include "verify.h"
+
\f
+/*
+ * These compile-time tests verify the properties needed for the
+ * efficient test macros defined in boolean.h, which are defined in
+ * terms of the SCM_MATCHES_BITS_IN_COMMON macro.
+ *
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
+ */
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_BOOL_F, SCM_BOOL_T));
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL, SCM_BOOL_F));
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL, SCM_EOL));
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
+ (SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, \
+ SCM_XXX_ANOTHER_BOOLEAN_DONT_USE));
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
+ (SCM_ELISP_NIL, SCM_BOOL_F, SCM_EOL, \
+ SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE));
SCM_DEFINE (scm_not, "not", 1, 0, 0,
(SCM x),
"Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}.")
#define FUNC_NAME s_scm_not
{
- return scm_from_bool (scm_is_false (x) || SCM_NILP (x));
+ return scm_from_bool (scm_is_false_or_nil (x));
}
#undef FUNC_NAME
"Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}.")
#define FUNC_NAME s_scm_boolean_p
{
- return scm_from_bool (scm_is_bool (obj) || SCM_NILP (obj));
+ return scm_from_bool (scm_is_bool_or_nil (obj));
}
#undef FUNC_NAME
-int
-scm_is_bool (SCM x)
-{
- return scm_is_eq (x, SCM_BOOL_F) || scm_is_eq (x, SCM_BOOL_T);
-}
-
int
scm_to_bool (SCM x)
{
+ /* XXX Should this first test use scm_is_false_or_nil instead? */
if (scm_is_eq (x, SCM_BOOL_F))
return 0;
else if (scm_is_eq (x, SCM_BOOL_T))
#ifndef SCM_BOOLEAN_H
#define SCM_BOOLEAN_H
-/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000, 2006, 2008, 2009 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
*
*/
+/*
+ * Use these macros if it's important (for correctness)
+ * that %nil MUST be considered true
+ */
+#define scm_is_false_and_not_nil(x) (scm_is_eq ((x), SCM_BOOL_F))
+#define scm_is_true_or_nil(x) (!scm_is_eq ((x), SCM_BOOL_F))
+
+/*
+ * Use these macros if %nil will never be tested,
+ * for increased efficiency.
+ */
+#define scm_is_false_assume_not_nil(x) (scm_is_eq ((x), SCM_BOOL_F))
+#define scm_is_true_assume_not_nil(x) (!scm_is_eq ((x), SCM_BOOL_F))
+
+/*
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information on
+ * how the following macro works.
+ */
+#if SCM_ENABLE_ELISP
+# define scm_is_false_or_nil(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_BOOL_F))
+#else
+# define scm_is_false_or_nil(x) (scm_is_false_assume_not_nil (x))
+#endif
+#define scm_is_true_and_not_nil(x) (!scm_is_false_or_nil (x))
-#define scm_is_false(x) scm_is_eq ((x), SCM_BOOL_F)
-#define scm_is_true(x) !scm_is_false (x)
+/* XXX Should these macros treat %nil as false by default? */
+#define scm_is_false(x) (scm_is_false_and_not_nil (x))
+#define scm_is_true(x) (!scm_is_false (x))
+
+/*
+ * Since we know SCM_BOOL_F and SCM_BOOL_T differ by exactly one bit,
+ * and that SCM_BOOL_F and SCM_ELISP_NIL differ by exactly one bit,
+ * and that they of course can't be the same bit (or else SCM_BOOL_T
+ * and SCM_ELISP_NIL be would equal), it follows that SCM_BOOL_T and
+ * SCM_ELISP_NIL differ by exactly two bits, and these are the bits
+ * which will be ignored by SCM_MATCHES_BITS_IN_COMMON below.
+ *
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
+ *
+ * If SCM_ENABLE_ELISP is true, then scm_is_bool_or_nil(x)
+ * returns 1 if and only if x is one of the following: SCM_BOOL_F,
+ * SCM_BOOL_T, SCM_ELISP_NIL, or SCM_XXX_ANOTHER_BOOLEAN_DONT_USE.
+ * Otherwise, it returns 0.
+ */
+#if SCM_ENABLE_ELISP
+# define scm_is_bool_or_nil(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_T, SCM_ELISP_NIL))
+#else
+# define scm_is_bool_or_nil(x) (scm_is_bool_and_not_nil (x))
+#endif
+
+#define scm_is_bool_and_not_nil(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_F, SCM_BOOL_T))
+
+/* XXX Should scm_is_bool treat %nil as a boolean? */
+#define scm_is_bool(x) (scm_is_bool_and_not_nil (x))
-SCM_API int scm_is_bool (SCM x);
#define scm_from_bool(x) ((x) ? SCM_BOOL_T : SCM_BOOL_F)
SCM_API int scm_to_bool (SCM x);
\f
+/*
+ * The following macros efficiently implement boolean truth testing as
+ * expected by most lisps, which treat '() aka SCM_EOL as false.
+ *
+ * Since we know SCM_ELISP_NIL and SCM_BOOL_F differ by exactly one
+ * bit, and that SCM_ELISP_NIL and SCM_EOL differ by exactly one bit,
+ * and that they of course can't be the same bit (or else SCM_BOOL_F
+ * and SCM_EOL be would equal), it follows that SCM_BOOL_F and SCM_EOL
+ * differ by exactly two bits, and these are the bits which will be
+ * ignored by SCM_MATCHES_BITS_IN_COMMON below.
+ *
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
+ *
+ * scm_is_lisp_false(x) returns 1 if and only if x is one of the
+ * following: SCM_BOOL_F, SCM_ELISP_NIL, SCM_EOL or
+ * SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE. Otherwise, it returns 0.
+ */
+#if SCM_ENABLE_ELISP
+# define scm_is_lisp_false(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_F, SCM_EOL))
+# define scm_is_lisp_true(x) (!scm_is_lisp_false(x))
+#endif
+
+\f
+
SCM_API SCM scm_not (SCM x);
SCM_API SCM scm_boolean_p (SCM obj);
#endif
#include <alloca.h>
+#include <assert.h>
#include <gmp.h>
#include <byteswap.h>
#include <striconveh.h>
#include <uniconv.h>
+#include <unistr.h>
#ifdef HAVE_LIMITS_H
# include <limits.h>
\f
/* Bytevector type. */
-scm_t_bits scm_tc16_bytevector;
+#define SCM_BYTEVECTOR_HEADER_BYTES \
+ (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (SCM))
-#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
-#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
- ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
- SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
-#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
- SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
-#define SCM_BYTEVECTOR_SET_INLINE(bv) \
- SCM_SET_SMOB_FLAGS (bv, SCM_SMOB_FLAGS (bv) | SCM_F_BYTEVECTOR_INLINE)
-#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
- SCM_SET_SMOB_FLAGS (bv, (SCM_SMOB_FLAGS (bv) & 0xFF) | (hint << 8))
+ SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \
+ SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
+#define SCM_BYTEVECTOR_SET_CONTIGUOUS_P(bv, contiguous_p) \
+ SCM_SET_BYTEVECTOR_FLAGS ((bv), \
+ SCM_BYTEVECTOR_ELEMENT_TYPE (bv) \
+ | ((contiguous_p) << 8UL))
+
+#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
+ SCM_SET_BYTEVECTOR_FLAGS ((bv), \
+ (hint) \
+ | (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL))
#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
(scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
- SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var)
+ (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
/* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED;
static inline SCM
-make_bytevector_from_buffer (size_t len, void *contents,
- scm_t_array_element_type element_type)
+make_bytevector (size_t len, scm_t_array_element_type element_type)
{
SCM ret;
size_t c_len;
-
+
if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
|| scm_i_array_element_type_sizes[element_type] < 8
|| len >= (SCM_I_SIZE_MAX
/ (scm_i_array_element_type_sizes[element_type]/8))))
/* This would be an internal Guile programming error */
abort ();
-
- c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
- if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_len))
- SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, contents);
+
+ if (SCM_UNLIKELY (len == 0 && element_type == SCM_ARRAY_ELEMENT_TYPE_VU8
+ && SCM_BYTEVECTOR_P (scm_null_bytevector)))
+ ret = scm_null_bytevector;
else
{
- SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, NULL);
- SCM_BYTEVECTOR_SET_INLINE (ret);
- if (contents)
- {
- memcpy (SCM_BYTEVECTOR_CONTENTS (ret), contents, c_len);
- scm_gc_free (contents, c_len, SCM_GC_BYTEVECTOR);
- }
+ signed char *contents;
+
+ c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
+
+ contents = scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES + c_len,
+ SCM_GC_BYTEVECTOR);
+ ret = PTR2SCM (contents);
+ contents += SCM_BYTEVECTOR_HEADER_BYTES;
+
+ SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
+ SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
+ SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 1);
+ SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
}
- SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+
return ret;
}
+/* Return a bytevector of LEN elements of type ELEMENT_TYPE, with element
+ values taken from CONTENTS. Assume that the storage for CONTENTS will be
+ automatically reclaimed when it becomes unreachable. */
static inline SCM
-make_bytevector (size_t len, scm_t_array_element_type element_type)
+make_bytevector_from_buffer (size_t len, void *contents,
+ scm_t_array_element_type element_type)
{
- size_t c_len;
-
- if (SCM_UNLIKELY (len == 0 && element_type == 0))
- return scm_null_bytevector;
- else if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
- || scm_i_array_element_type_sizes[element_type] < 8
- || len >= (SCM_I_SIZE_MAX
- / (scm_i_array_element_type_sizes[element_type]/8))))
- /* This would be an internal Guile programming error */
- abort ();
+ SCM ret;
- c_len = len * (scm_i_array_element_type_sizes[element_type]/8);
- if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_len))
- {
- SCM ret;
- SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, NULL);
- SCM_BYTEVECTOR_SET_INLINE (ret);
- SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
- return ret;
- }
+ if (SCM_UNLIKELY (len == 0))
+ ret = make_bytevector (len, element_type);
else
{
- void *buf = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
- return make_bytevector_from_buffer (len, buf, element_type);
+ size_t c_len;
+
+ ret = PTR2SCM (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
+ SCM_GC_BYTEVECTOR));
+
+ c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
+
+ SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
+ SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
+ SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 0);
+ SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
}
+
+ return ret;
}
+
/* Return a new bytevector of size LEN octets. */
SCM
scm_c_make_bytevector (size_t len)
return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8);
}
-/* Return a new bytevector of size LEN elements. */
-SCM
-scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
-{
- return make_bytevector (len, element_type);
-}
-
/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
SCM
return make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
}
-SCM
-scm_c_take_typed_bytevector (signed char *contents, size_t len,
- scm_t_array_element_type element_type)
-{
- return make_bytevector_from_buffer (len, contents, element_type);
-}
-
/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
- size) and return BV. */
+ size) and return the new bytevector (possibly different from BV). */
SCM
-scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
+scm_c_shrink_bytevector (SCM bv, size_t c_new_len)
{
+ SCM new_bv;
+ size_t c_len;
+
if (SCM_UNLIKELY (c_new_len % SCM_BYTEVECTOR_TYPE_SIZE (bv)))
/* This would be an internal Guile programming error */
abort ();
- if (!SCM_BYTEVECTOR_INLINE_P (bv))
- {
- size_t c_len;
- signed char *c_bv, *c_new_bv;
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ if (SCM_UNLIKELY (c_new_len > c_len))
+ abort ();
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
- c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
- SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
+ if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv))
+ new_bv = PTR2SCM (scm_gc_realloc (SCM2PTR (bv),
+ c_len + SCM_BYTEVECTOR_HEADER_BYTES,
+ c_new_len + SCM_BYTEVECTOR_HEADER_BYTES,
+ SCM_GC_BYTEVECTOR));
+ else
+ {
+ signed char *c_bv;
- if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
- {
- /* Copy to the in-line buffer and free the current buffer. */
- SCM_BYTEVECTOR_SET_INLINE (bv);
- c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv);
- memcpy (c_new_bv, c_bv, c_new_len);
- scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
- }
- else
- {
- /* Resize the existing buffer. */
- c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len,
- SCM_GC_BYTEVECTOR);
- SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
- }
+ c_bv = scm_gc_realloc (SCM_BYTEVECTOR_CONTENTS (bv),
+ c_len, c_new_len, SCM_GC_BYTEVECTOR);
+ SCM_BYTEVECTOR_SET_CONTENTS (bv, c_bv);
+
+ new_bv = bv;
}
- else
- SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
- return bv;
+ return new_bv;
}
int
scm_is_bytevector (SCM obj)
{
- return SCM_SMOB_PREDICATE (scm_tc16_bytevector, obj);
+ return SCM_BYTEVECTOR_P (obj);
}
size_t
\f
-
-
-static int
-print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
+int
+scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
ssize_t ubnd, inc, i;
scm_t_array_handle h;
return 1;
}
-static SCM
-bytevector_equal_p (SCM bv1, SCM bv2)
-{
- return scm_bytevector_eq_p (bv1, bv2);
-}
-
-static size_t
-free_bytevector (SCM bv)
-{
-
- if (!SCM_BYTEVECTOR_INLINE_P (bv))
- {
- unsigned c_len;
- signed char *c_bv;
-
- c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
-
- scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
- }
-
- return 0;
-}
-
-
\f
/* General operations. */
#define FUNC_NAME s_scm_uniform_array_to_bytevector
{
SCM contents, ret;
- size_t len;
+ size_t len, sz, byte_len;
scm_t_array_handle h;
- const void *base;
- size_t sz;
+ const void *elts;
contents = scm_array_contents (array, SCM_BOOL_T);
if (scm_is_false (contents))
scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
scm_array_get_handle (contents, &h);
+ assert (h.base == 0);
- base = scm_array_handle_uniform_elements (&h);
+ elts = h.elements;
len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
- sz = scm_array_handle_uniform_element_size (&h);
+ sz = scm_array_handle_uniform_element_bit_size (&h);
+ if (sz >= 8 && ((sz % 8) == 0))
+ byte_len = len * (sz / 8);
+ else if (sz < 8)
+ /* byte_len = ceil (len * sz / 8) */
+ byte_len = (len * sz + 7) / 8;
+ else
+ /* an internal guile error, really */
+ SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
- ret = make_bytevector (len * sz, SCM_ARRAY_ELEMENT_TYPE_VU8);
- memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
+ ret = make_bytevector (byte_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (ret), elts, byte_len);
scm_array_handle_release (&h);
#define MAX_UTF_ENCODING_NAME_LEN 16
/* Produce the body of a `string->utf' function. */
-#define STRING_TO_UTF(_utf_width) \
- SCM utf; \
- int err; \
- char *c_str; \
- char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
- char *c_utf = NULL, *c_locale; \
- size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
- \
- SCM_VALIDATE_STRING (1, str); \
- if (endianness == SCM_UNDEFINED) \
- endianness = scm_sym_big; \
- else \
- SCM_VALIDATE_SYMBOL (2, endianness); \
- \
- c_strlen = scm_c_string_length (str); \
- c_raw_strlen = c_strlen * ((_utf_width) / 8); \
- do \
- { \
- c_str = (char *) alloca (c_raw_strlen + 1); \
- c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
- } \
- while (c_raw_strlen > c_strlen); \
- c_str[c_raw_strlen] = '\0'; \
- \
- utf_encoding_name (c_utf_name, (_utf_width), endianness); \
- \
- c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
- strcpy (c_locale, locale_charset ()); \
- \
- err = mem_iconveh (c_str, c_raw_strlen, \
- c_locale, c_utf_name, \
- iconveh_question_mark, NULL, \
- &c_utf, &c_utf_len); \
- if (SCM_UNLIKELY (err)) \
- scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
- scm_list_1 (str), err); \
- else \
- /* C_UTF is null-terminated. */ \
- utf = scm_c_take_bytevector ((signed char *) c_utf, c_utf_len); \
- \
- return (utf);
+#define STRING_TO_UTF(_utf_width) \
+ SCM utf; \
+ int err; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ char *c_utf = NULL; \
+ size_t c_strlen, c_utf_len = 0; \
+ \
+ SCM_VALIDATE_STRING (1, str); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_strlen = scm_i_string_length (str); \
+ if (scm_i_is_narrow_string (str)) \
+ { \
+ err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
+ "ISO-8859-1", c_utf_name, \
+ iconveh_question_mark, NULL, \
+ &c_utf, &c_utf_len); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), err); \
+ } \
+ else \
+ { \
+ const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
+ c_utf = u32_conv_to_encoding (c_utf_name, \
+ iconveh_question_mark, \
+ (scm_t_uint32 *) wbuf, \
+ c_strlen, NULL, NULL, &c_utf_len); \
+ if (SCM_UNLIKELY (c_utf == NULL)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), errno); \
+ } \
+ scm_dynwind_begin (0); \
+ scm_dynwind_free (c_utf); \
+ utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
+ memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
+ scm_dynwind_end (); \
+ \
+ return (utf);
#define FUNC_NAME s_scm_string_to_utf8
{
SCM utf;
- char *c_str;
uint8_t *c_utf;
- size_t c_strlen, c_raw_strlen;
+ size_t c_strlen, c_utf_len = 0;
SCM_VALIDATE_STRING (1, str);
- c_strlen = scm_c_string_length (str);
- c_raw_strlen = c_strlen;
- do
+ c_strlen = scm_i_string_length (str);
+ if (scm_i_is_narrow_string (str))
+ c_utf = u8_conv_from_encoding ("ISO-8859-1", iconveh_question_mark,
+ scm_i_string_chars (str), c_strlen,
+ NULL, NULL, &c_utf_len);
+ else
{
- c_str = (char *) alloca (c_raw_strlen + 1);
- c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
+ const scm_t_wchar *wbuf = scm_i_string_wide_chars (str);
+ c_utf = u32_to_u8 ((const uint32_t *) wbuf, c_strlen, NULL, &c_utf_len);
}
- while (c_raw_strlen > c_strlen);
- c_str[c_raw_strlen] = '\0';
-
- c_utf = u8_strconv_from_locale (c_str);
if (SCM_UNLIKELY (c_utf == NULL))
scm_syserror (FUNC_NAME);
else
- /* C_UTF is null-terminated. */
- utf = scm_c_take_bytevector ((signed char *) c_utf,
- UTF_STRLEN (8, c_utf));
+ {
+ scm_dynwind_begin (0);
+ scm_dynwind_free (c_utf);
+
+ utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len);
+
+ scm_dynwind_end ();
+ }
return (utf);
}
#define UTF_TO_STRING(_utf_width) \
SCM str = SCM_BOOL_F; \
int err; \
- char *c_str = NULL, *c_locale; \
+ char *c_str = NULL; \
char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
- const char *c_utf; \
- size_t c_strlen = 0, c_utf_len; \
+ char *c_utf; \
+ size_t c_strlen = 0, c_utf_len = 0; \
\
SCM_VALIDATE_BYTEVECTOR (1, utf); \
if (endianness == SCM_UNDEFINED) \
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
utf_encoding_name (c_utf_name, (_utf_width), endianness); \
\
- c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
- strcpy (c_locale, locale_charset ()); \
- \
err = mem_iconveh (c_utf, c_utf_len, \
- c_utf_name, c_locale, \
+ c_utf_name, "UTF-8", \
iconveh_question_mark, NULL, \
&c_str, &c_strlen); \
if (SCM_UNLIKELY (err)) \
scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
scm_list_1 (utf), err); \
else \
- /* C_STR is null-terminated. */ \
- str = scm_take_locale_stringn (c_str, c_strlen); \
- \
+ { \
+ str = scm_from_stringn (c_str, c_strlen, "UTF-8", \
+ SCM_FAILED_CONVERSION_ERROR); \
+ free (c_str); \
+ } \
return (str);
#define FUNC_NAME s_scm_utf8_to_string
{
SCM str;
- int err;
- char *c_str = NULL, *c_locale;
const char *c_utf;
- size_t c_utf_len, c_strlen = 0;
+ size_t c_utf_len = 0;
SCM_VALIDATE_BYTEVECTOR (1, utf);
c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
-
- c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
- strcpy (c_locale, locale_charset ());
-
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
- err = mem_iconveh (c_utf, c_utf_len,
- "UTF-8", c_locale,
- iconveh_question_mark, NULL,
- &c_str, &c_strlen);
- if (SCM_UNLIKELY (err))
- scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
- scm_list_1 (utf), err);
- else
- /* C_STR is null-terminated. */
- str = scm_take_locale_stringn (c_str, c_strlen);
+ str = scm_from_stringn (c_utf, c_utf_len, "UTF-8",
+ SCM_FAILED_CONVERSION_ERROR);
return (str);
}
}
#undef FUNC_NAME
-
\f
/* Bytevectors as generalized vectors & arrays. */
void
scm_bootstrap_bytevectors (void)
{
- /* The SMOB type must be instantiated here because the
- generalized-vector API may want to access bytevectors even though
- `(rnrs bytevector)' hasn't been loaded. */
- scm_tc16_bytevector = scm_make_smob_type ("bytevector", 0);
- scm_set_smob_free (scm_tc16_bytevector, free_bytevector);
- scm_set_smob_print (scm_tc16_bytevector, print_bytevector);
- scm_set_smob_equalp (scm_tc16_bytevector, bytevector_equal_p);
-
- scm_null_bytevector =
- scm_gc_protect_object
- (make_bytevector_from_buffer (0, NULL, SCM_ARRAY_ELEMENT_TYPE_VU8));
+ /* This must be instantiated here because the generalized-vector API may
+ want to access bytevectors even though `(rnrs bytevector)' hasn't been
+ loaded. */
+ scm_null_bytevector = make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8);
#ifdef WORDS_BIGENDIAN
- scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("big"));
+ scm_i_native_endianness = scm_from_locale_symbol ("big");
#else
- scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("little"));
+ scm_i_native_endianness = scm_from_locale_symbol ("little");
#endif
scm_c_register_extension ("libguile", "scm_init_bytevectors",
{
scm_t_array_implementation impl;
-
- impl.tag = scm_tc16_bytevector;
- impl.mask = 0xffff;
+
+ impl.tag = scm_tc7_bytevector;
+ impl.mask = 0x7f;
impl.vref = bv_handle_ref;
impl.vset = bv_handle_set_x;
impl.get_handle = bytevector_get_handle;
/* R6RS bytevectors. */
+/* The size in words of the bytevector header (type tag and flags, length,
+ and pointer to the underlying buffer). */
+#define SCM_BYTEVECTOR_HEADER_SIZE 3U
+
#define SCM_BYTEVECTOR_LENGTH(_bv) \
- ((size_t) SCM_SMOB_DATA (_bv))
+ ((size_t) SCM_CELL_WORD_1 (_bv))
#define SCM_BYTEVECTOR_CONTENTS(_bv) \
- (SCM_BYTEVECTOR_INLINE_P (_bv) \
- ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \
- : (signed char *) SCM_SMOB_DATA_2 (_bv))
+ ((signed char *) SCM_CELL_WORD_2 (_bv))
SCM_API SCM scm_endianness_big;
\f
/* Internal API. */
-/* The threshold (in octets) under which bytevectors are stored "in-line",
- i.e., without allocating memory beside the SMOB itself (a double cell).
- This optimization is necessary since small bytevectors are expected to be
- common. */
-#define SCM_BYTEVECTOR_P(_bv) \
- SCM_SMOB_PREDICATE (scm_tc16_bytevector, _bv)
-#define SCM_F_BYTEVECTOR_INLINE 0x1
-#define SCM_BYTEVECTOR_INLINE_P(_bv) \
- (SCM_SMOB_FLAGS (_bv) & SCM_F_BYTEVECTOR_INLINE)
+#define SCM_BYTEVECTOR_P(x) \
+ (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_bytevector)
+#define SCM_BYTEVECTOR_FLAGS(_bv) \
+ (SCM_CELL_TYPE (_bv) >> 7UL)
+#define SCM_SET_BYTEVECTOR_FLAGS(_bv, _f) \
+ SCM_SET_CELL_TYPE ((_bv), \
+ scm_tc7_bytevector | ((scm_t_bits)(_f) << 7UL))
+
#define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \
- (SCM_SMOB_FLAGS (_bv) >> 8)
+ (SCM_BYTEVECTOR_FLAGS (_bv) & 0xffUL)
+#define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \
+ (SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL)
/* Hint that is passed to `scm_gc_malloc ()' and friends. */
#define SCM_GC_BYTEVECTOR "bytevector"
-SCM_INTERNAL SCM scm_i_make_typed_bytevector (size_t, scm_t_array_element_type);
-SCM_INTERNAL SCM scm_c_take_typed_bytevector (signed char *, size_t,
- scm_t_array_element_type);
-
SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);
-SCM_INTERNAL scm_t_bits scm_tc16_bytevector;
SCM_INTERNAL SCM scm_i_native_endianness;
SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t);
-#define scm_c_shrink_bytevector(_bv, _len) \
- (SCM_BYTEVECTOR_INLINE_P (_bv) \
- ? (_bv) \
- : scm_i_shrink_bytevector ((_bv), (_len)))
+SCM_INTERNAL int scm_i_print_bytevector (SCM, SCM, scm_print_state *);
-SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, size_t);
+SCM_INTERNAL SCM scm_c_shrink_bytevector (SCM, size_t);
SCM_INTERNAL void scm_i_bytevector_generalized_set_x (SCM, size_t, SCM);
SCM_INTERNAL SCM scm_null_bytevector;
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_eq_p
+SCM_DEFINE (scm_i_char_eq_p, "char=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is equal to the\n"
+ "code point of @var{y}, else @code{#f}.\n")
+#define FUNC_NAME s_scm_i_char_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_eq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_eq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_eq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff @var{x} is less than @var{y} in the Unicode sequence,\n"
- "else @code{#f}.")
-#define FUNC_NAME s_scm_char_less_p
+SCM_DEFINE (scm_i_char_less_p, "char<?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the code point of @var{x} is less than the code\n"
+ "point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_less_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_less_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_less_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
- "Unicode sequence, else @code{#f}.")
-#define FUNC_NAME s_scm_char_leq_p
+SCM_DEFINE (scm_i_char_leq_p, "char<=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is less than or\n"
+ "equal to the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_leq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_leq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_leq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff @var{x} is greater than @var{y} in the Unicode\n"
- "sequence, else @code{#f}.")
-#define FUNC_NAME s_scm_char_gr_p
+SCM_DEFINE (scm_i_char_gr_p, "char>?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
+ "the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_gr_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_gr_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_gr_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
- "Unicode sequence, else @code{#f}.")
-#define FUNC_NAME s_scm_char_geq_p
+SCM_DEFINE (scm_i_char_geq_p, "char>=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
+ "or equal to the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_geq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_geq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_geq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n"
- "case, else @code{#f}. Case is locale free and not context sensitive.")
-#define FUNC_NAME s_scm_char_ci_eq_p
+/* FIXME?: R6RS specifies that these comparisons are case-folded.
+ This is the same thing as comparing the uppercase characters in
+ practice, but, not in theory. Unicode has table containing their
+ definition of case-folded character mappings. A more correct
+ implementation would be to use that table and make a char-foldcase
+ function. */
+
+SCM_DEFINE (scm_i_char_ci_eq_p, "char-ci=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
+ "the same as the case-folded code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_eq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_eq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_eq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
- "than the Unicode uppercase form @var{y} in the Unicode sequence,\n"
- "else @code{#f}.")
-#define FUNC_NAME s_scm_char_ci_less_p
+SCM_DEFINE (scm_i_char_ci_less_p, "char-ci<?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
+ "less than the case-folded code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_less_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_less_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_less_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
- "than or equal to the Unicode uppercase form of @var{y} in the\n"
- "Unicode sequence, else @code{#f}.")
-#define FUNC_NAME s_scm_char_ci_leq_p
+SCM_DEFINE (scm_i_char_ci_leq_p, "char-ci<=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded Unicodd code point of @var{x} is\n"
+ "less than or equal to the case-folded code point of @var{y}, else\n"
+ "@code{#f}")
+#define FUNC_NAME s_scm_i_char_ci_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_leq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_leq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_leq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
- "than the Unicode uppercase form of @var{y} in the Unicode\n"
- "sequence, else @code{#f}.")
-#define FUNC_NAME s_scm_char_ci_gr_p
+SCM_DEFINE (scm_i_char_ci_gr_p, "char-ci>?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded code point of @var{x} is greater\n"
+ "than the case-folded code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_gr_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_gr_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_gr_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
- "than or equal to the Unicode uppercase form of @var{y} in the\n"
- "Unicode sequence, else @code{#f}.")
-#define FUNC_NAME s_scm_char_ci_geq_p
+SCM_DEFINE (scm_i_char_ci_geq_p, "char-ci>=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n"
+ "greater than or equal to the case-folded code point of @var{y}, else\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_geq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_geq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_geq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
#undef FUNC_NAME
-
SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n")
#undef FUNC_NAME
-
SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
(SCM chr),
- "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}.\n")
+ "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else\n"
+ "@code{#f}.\n")
#define FUNC_NAME s_scm_char_is_both_p
{
if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr)))
#undef FUNC_NAME
-
-
SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
(SCM chr),
- "Return the number corresponding to ordinal position of @var{chr} in the\n"
- "ASCII sequence.")
+ "Return the Unicode code point of @var{chr}.")
#define FUNC_NAME s_scm_char_to_integer
{
SCM_VALIDATE_CHAR (1, chr);
#undef FUNC_NAME
-
SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
(SCM n),
- "Return the character at position @var{n} in the ASCII sequence.")
+ "Return the character that has Unicode code point @var{n}. The integer\n"
+ "@var{n} must be a valid code point. Valid code points are in the\n"
+ "ranges 0 to @code{#xD7FF} inclusive or @code{#xE000} to\n"
+ "@code{#x10FFFF} inclusive.")
#define FUNC_NAME s_scm_integer_to_char
{
scm_t_wchar cn;
? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char) \
: SCM_MAKE_ITAG8 ((scm_t_bits) (x), scm_tc8_char))
+#define SCM_CODEPOINT_DOTTED_CIRCLE (0x25cc)
+#define SCM_CODEPOINT_SURROGATE_START (0xd800)
+#define SCM_CODEPOINT_SURROGATE_END (0xdfff)
#define SCM_CODEPOINT_MAX (0x10ffff)
#define SCM_IS_UNICODE_CHAR(c) \
- ((scm_t_wchar) (c) <= 0xd7ff \
- || ((scm_t_wchar) (c) >= 0xe000 && (scm_t_wchar) (c) <= SCM_CODEPOINT_MAX))
+ (((scm_t_wchar) (c) >= 0 \
+ && (scm_t_wchar) (c) < SCM_CODEPOINT_SURROGATE_START) \
+ || ((scm_t_wchar) (c) > SCM_CODEPOINT_SURROGATE_END \
+ && (scm_t_wchar) (c) <= SCM_CODEPOINT_MAX))
\f
-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009 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
scm_t_bits scm_tc16_continuation;
-static SCM
-continuation_mark (SCM obj)
-{
- scm_t_contregs *continuation = SCM_CONTREGS (obj);
-
- scm_gc_mark (continuation->root);
- scm_gc_mark (continuation->throw_value);
- scm_gc_mark (continuation->vm_conts);
- scm_mark_locations (continuation->stack, continuation->num_stack_items);
-#ifdef __ia64__
- if (continuation->backing_store)
- scm_mark_locations (continuation->backing_store,
- continuation->backing_store_size /
- sizeof (SCM_STACKITEM));
-#endif /* __ia64__ */
- return continuation->dynenv;
-}
-
-static size_t
-continuation_free (SCM obj)
-{
- scm_t_contregs *continuation = SCM_CONTREGS (obj);
- /* stack array size is 1 if num_stack_items is 0. */
- size_t extra_items = (continuation->num_stack_items > 0)
- ? (continuation->num_stack_items - 1)
- : 0;
- size_t bytes_free = sizeof (scm_t_contregs)
- + extra_items * sizeof (SCM_STACKITEM);
-
-#ifdef __ia64__
- scm_gc_free (continuation->backing_store, continuation->backing_store_size,
- "continuation backing store");
-#endif /* __ia64__ */
- scm_gc_free (continuation, bytes_free, "continuation");
- return 0;
-}
static int
continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
scm_puts ("#<continuation ", port);
scm_intprint (continuation->num_stack_items, 10, port);
scm_puts (" @ ", port);
- scm_uintprint (SCM_CELL_WORD_1 (obj), 16, port);
+ scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
scm_putc ('>', port);
return 1;
}
continuation->dynenv = scm_i_dynwinds ();
continuation->throw_value = SCM_EOL;
continuation->root = thread->continuation_root;
- continuation->dframe = scm_i_last_debug_frame ();
src = thread->continuation_base;
#if ! SCM_STACK_GROWS_UP
src -= stack_size;
data.dst = dst;
scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
- scm_i_set_last_debug_frame (continuation->dframe);
-
continuation->throw_value = val;
SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
SCM_STACKITEM *dst = thread->continuation_base;
SCM_STACKITEM stack_top_element;
- if (scm_i_critical_section_level)
+ if (thread->critical_section_level)
{
fprintf (stderr, "continuation invoked from within critical section.\n");
abort ();
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM old_controot;
SCM_STACKITEM *old_contbase;
- scm_t_debug_frame *old_lastframe;
SCM result;
/* Establish a fresh continuation root.
*/
old_controot = thread->continuation_root;
old_contbase = thread->continuation_base;
- old_lastframe = thread->last_debug_frame;
thread->continuation_root = scm_cons (thread->handle, old_controot);
thread->continuation_base = &stack_item;
- thread->last_debug_frame = NULL;
/* Call FUNC inside a catch all. This is now guaranteed to return
directly and exactly once.
/* Return to old continuation root.
*/
- thread->last_debug_frame = old_lastframe;
thread->continuation_base = old_contbase;
thread->continuation_root = old_controot;
scm_init_continuations ()
{
scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
- scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
- scm_set_smob_free (scm_tc16_continuation, continuation_free);
scm_set_smob_print (scm_tc16_continuation, continuation_print);
scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
#include "libguile/continuations.x"
#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009 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
*/
scm_t_ptrdiff offset;
- /* The most recently created debug frame on the live stack, before
- it was saved. This needs to be adjusted with OFFSET, above.
- */
- struct scm_t_debug_frame *dframe;
-
SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */
} scm_t_contregs;
#define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x)
-#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_CELL_WORD_1 (x))
+#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
#define SCM_SET_CONTINUATION_LENGTH(x, n)\
return n;
#else
-#if TYPE_MIN == 0
- if (n <= TYPE_MAX)
- return n;
-#else /* TYPE_MIN != 0 */
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
-#endif /* TYPE_MIN != 0 */
else
goto out_of_range;
mpz_export (&n, &count, 1, sizeof (TYPE), 0, 0, SCM_I_BIG_MPZ (val));
-#if TYPE_MIN == 0
- if (n <= TYPE_MAX)
- return n;
-#else /* TYPE_MIN != 0 */
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
-#endif /* TYPE_MIN != 0 */
else
goto out_of_range;
-/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 Free Software Foundation
- *
- * 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
-
-#ifdef HAVE_GETRLIMIT
-#include <sys/time.h>
-#include <sys/resource.h>
-#endif
-
-#include "libguile/_scm.h"
-#include "libguile/async.h"
-#include "libguile/eval.h"
-#include "libguile/list.h"
-#include "libguile/stackchk.h"
-#include "libguile/throw.h"
-#include "libguile/macros.h"
-#include "libguile/smob.h"
-#include "libguile/procprop.h"
-#include "libguile/srcprop.h"
-#include "libguile/alist.h"
-#include "libguile/continuations.h"
-#include "libguile/strports.h"
-#include "libguile/read.h"
-#include "libguile/feature.h"
-#include "libguile/dynwind.h"
-#include "libguile/modules.h"
-#include "libguile/ports.h"
-#include "libguile/root.h"
-#include "libguile/fluids.h"
-#include "libguile/objects.h"
-#include "libguile/programs.h"
-
-#include "libguile/validate.h"
-#include "libguile/debug.h"
-
-#include "libguile/private-options.h"
-\f
-
-
-/* {Run time control of the debugging evaluator}
- */
-
-SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
- (SCM setting),
- "Option interface for the debug options. Instead of using\n"
- "this procedure directly, use the procedures @code{debug-enable},\n"
- "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
-#define FUNC_NAME s_scm_debug_options
-{
- SCM ans;
-
- scm_dynwind_begin (0);
- scm_dynwind_critical_section (SCM_BOOL_F);
-
- ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
- if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
- {
- scm_options (ans, scm_debug_opts, FUNC_NAME);
- SCM_OUT_OF_RANGE (1, setting);
- }
- SCM_RESET_DEBUG_MODE;
-#ifdef STACK_CHECKING
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
- scm_debug_eframe_size = 2 * SCM_N_FRAMES;
-
- scm_dynwind_end ();
- return ans;
-}
-#undef FUNC_NAME
-
-
-static void
-with_traps_before (void *data)
-{
- int *trap_flag = data;
- *trap_flag = SCM_TRAPS_P;
- SCM_TRAPS_P = 1;
-}
-
-static void
-with_traps_after (void *data)
-{
- int *trap_flag = data;
- SCM_TRAPS_P = *trap_flag;
-}
-
-static SCM
-with_traps_inner (void *data)
-{
- SCM thunk = SCM_PACK ((scm_t_bits) data);
- return scm_call_0 (thunk);
-}
-
-SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
- (SCM thunk),
- "Call @var{thunk} with traps enabled.")
-#define FUNC_NAME s_scm_with_traps
-{
- int trap_flag;
- SCM_VALIDATE_THUNK (1, thunk);
- return scm_internal_dynamic_wind (with_traps_before,
- with_traps_inner,
- with_traps_after,
- (void *) SCM_UNPACK (thunk),
- &trap_flag);
-}
-#undef FUNC_NAME
-
-\f
-SCM_SYMBOL (scm_sym_procname, "procname");
-SCM_SYMBOL (scm_sym_dots, "...");
-SCM_SYMBOL (scm_sym_source, "source");
-
-/* {Memoized Source}
- */
-
-scm_t_bits scm_tc16_memoized;
-
-static int
-memoized_print (SCM obj, SCM port, scm_print_state *pstate)
-{
- int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<memoized ", port);
- SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
- SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
- return 1;
-}
-
-SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is memoized.")
-#define FUNC_NAME s_scm_memoized_p
-{
- return scm_from_bool(SCM_MEMOIZEDP (obj));
-}
-#undef FUNC_NAME
-
-SCM
-scm_make_memoized (SCM exp, SCM env)
-{
- /* *fixme* Check that env is a valid environment. */
- SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env)));
-}
-
-#ifdef GUILE_DEBUG
-/*
- * Some primitives for construction of memoized code
- *
- * - procedure: memcons CAR CDR [ENV]
- *
- * Construct a pair, encapsulated in a memoized object.
- *
- * The CAR and CDR can be either normal or memoized. If ENV isn't
- * specified, the top-level environment of the current module will
- * be assumed. All environments must match.
- *
- * - procedure: make-iloc FRAME BINDING CDRP
- *
- * Return an iloc referring to frame no. FRAME, binding
- * no. BINDING. If CDRP is non-#f, the iloc is referring to a
- * frame consisting of a single pair, with the value stored in the
- * CDR.
- *
- * - procedure: iloc? OBJECT
- *
- * Return #t if OBJECT is an iloc.
- *
- * - procedure: mem->proc MEMOIZED
- *
- * Construct a closure from the memoized lambda expression MEMOIZED
- *
- * WARNING! The code is not copied!
- *
- * - procedure: proc->mem CLOSURE
- *
- * Turn the closure CLOSURE into a memoized object.
- *
- * WARNING! The code is not copied!
- *
- * - constant: SCM_IM_AND
- * - constant: SCM_IM_BEGIN
- * - constant: SCM_IM_CASE
- * - constant: SCM_IM_COND
- * - constant: SCM_IM_DO
- * - constant: SCM_IM_IF
- * - constant: SCM_IM_LAMBDA
- * - constant: SCM_IM_LET
- * - constant: SCM_IM_LETSTAR
- * - constant: SCM_IM_LETREC
- * - constant: SCM_IM_OR
- * - constant: SCM_IM_QUOTE
- * - constant: SCM_IM_SET
- * - constant: SCM_IM_DEFINE
- * - constant: SCM_IM_APPLY
- * - constant: SCM_IM_CONT
- * - constant: SCM_IM_DISPATCH
- */
-
-#include "libguile/variable.h"
-#include "libguile/procs.h"
-
-SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
- (SCM car, SCM cdr, SCM env),
- "Return a new memoized cons cell with @var{car} and @var{cdr}\n"
- "as members and @var{env} as the environment.")
-#define FUNC_NAME s_scm_memcons
-{
- if (SCM_MEMOIZEDP (car))
- {
- /*fixme* environments may be two different but equal top-level envs */
- if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
- SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3",
- scm_list_2 (car, env));
- else
- env = SCM_MEMOIZED_ENV (car);
- car = SCM_MEMOIZED_EXP (car);
- }
- if (SCM_MEMOIZEDP (cdr))
- {
- if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
- SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3",
- scm_list_2 (cdr, env));
- else
- env = SCM_MEMOIZED_ENV (cdr);
- cdr = SCM_MEMOIZED_EXP (cdr);
- }
- if (SCM_UNBNDP (env))
- env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
- else
- SCM_VALIDATE_NULLORCONS (3, env);
- return scm_make_memoized (scm_cons (car, cdr), env);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
- (SCM obj),
- "Convert a memoized object (which must represent a body)\n"
- "to a procedure.")
-#define FUNC_NAME s_scm_mem_to_proc
-{
- SCM env;
- SCM_VALIDATE_MEMOIZED (1, obj);
- env = SCM_MEMOIZED_ENV (obj);
- obj = SCM_MEMOIZED_EXP (obj);
- return scm_closure (obj, env);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
- (SCM obj),
- "Convert a procedure to a memoized object.")
-#define FUNC_NAME s_scm_proc_to_mem
-{
- SCM_VALIDATE_CLOSURE (1, obj);
- return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj));
-}
-#undef FUNC_NAME
-
-#endif /* GUILE_DEBUG */
-
-SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0,
- (SCM m),
- "Unmemoize the memoized expression @var{m},")
-#define FUNC_NAME s_scm_i_unmemoize_expr
-{
- SCM_VALIDATE_MEMOIZED (1, m);
- return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0,
- (SCM m),
- "Return the environment of the memoized expression @var{m}.")
-#define FUNC_NAME s_scm_memoized_environment
-{
- SCM_VALIDATE_MEMOIZED (1, m);
- return SCM_MEMOIZED_ENV (m);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
- (SCM proc),
- "Return the name of the procedure @var{proc}")
-#define FUNC_NAME s_scm_procedure_name
-{
- SCM_VALIDATE_PROC (1, proc);
- switch (SCM_TYP7 (proc)) {
- case scm_tcs_subrs:
- return SCM_SUBR_NAME (proc);
- default:
- {
- SCM name = scm_procedure_property (proc, scm_sym_name);
-#if 0
- /* Source property scm_sym_procname not implemented yet... */
- SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname);
- if (scm_is_false (name))
- name = scm_procedure_property (proc, scm_sym_name);
-#endif
- if (scm_is_false (name) && SCM_CLOSUREP (proc))
- name = scm_reverse_lookup (SCM_ENV (proc), proc);
- if (scm_is_false (name) && SCM_PROGRAM_P (proc))
- name = scm_program_name (proc);
- return name;
- }
- }
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
- (SCM proc),
- "Return the source of the procedure @var{proc}.")
-#define FUNC_NAME s_scm_procedure_source
-{
- SCM_VALIDATE_NIM (1, proc);
- again:
- switch (SCM_TYP7 (proc)) {
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- const SCM body = SCM_CLOSURE_BODY (proc);
- const SCM src = scm_source_property (body, scm_sym_copy);
-
- if (scm_is_true (src))
- {
- return scm_cons2 (scm_sym_lambda, formals, src);
- }
- else
- {
- const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
- return scm_cons2 (scm_sym_lambda,
- scm_i_finite_list_copy (formals),
- scm_i_unmemocopy_body (body, env));
- }
- }
- case scm_tcs_struct:
- if (!SCM_I_OPERATORP (proc))
- break;
- goto procprop;
- case scm_tc7_smob:
- if (!SCM_SMOB_DESCRIPTOR (proc).apply)
- break;
- case scm_tcs_subrs:
- case scm_tc7_program:
- procprop:
- /* It would indeed be a nice thing if we supplied source even for
- built in procedures! */
- return scm_procedure_property (proc, scm_sym_source);
- case scm_tc7_pws:
- {
- SCM src = scm_procedure_property (proc, scm_sym_source);
- if (scm_is_true (src))
- return src;
- proc = SCM_PROCEDURE (proc);
- goto again;
- }
- default:
- ;
- }
- SCM_WRONG_TYPE_ARG (1, proc);
- return SCM_BOOL_F; /* not reached */
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
- (SCM proc),
- "Return the environment of the procedure @var{proc}.")
-#define FUNC_NAME s_scm_procedure_environment
-{
- SCM_VALIDATE_NIM (1, proc);
- switch (SCM_TYP7 (proc)) {
- case scm_tcs_closures:
- return SCM_ENV (proc);
- case scm_tcs_subrs:
- return SCM_EOL;
- default:
- SCM_WRONG_TYPE_ARG (1, proc);
- /* not reached */
- }
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
- (SCM proc),
- "Return the module that was current when @var{proc} was defined.")
-#define FUNC_NAME s_scm_procedure_module
-{
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- if (scm_is_true (scm_program_p (proc)))
- return scm_program_module (proc);
- else
- return scm_env_module (scm_procedure_environment (proc));
-}
-#undef FUNC_NAME
-
-
-\f
-
-/* Eval in a local environment. We would like to have the ability to
- * evaluate in a specified local environment, but due to the
- * memoization this isn't normally possible. We solve it by copying
- * the code before evaluating. One solution would be to have eval.c
- * generate yet another evaluator. They are not very big actually.
- */
-SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
- (SCM exp, SCM env),
- "Evaluate @var{exp} in its environment. If @var{env} is supplied,\n"
- "it is the environment in which to evaluate @var{exp}. Otherwise,\n"
- "@var{exp} must be a memoized code object (in which case, its environment\n"
- "is implicit).")
-#define FUNC_NAME s_scm_local_eval
-{
- if (SCM_UNBNDP (env))
- {
- SCM_VALIDATE_MEMOIZED (1, exp);
- return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
- }
- return scm_i_eval (exp, env);
-}
-#undef FUNC_NAME
-
-#if 0
-SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
-#endif
-
-SCM
-scm_reverse_lookup (SCM env, SCM data)
-{
- while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
- {
- SCM names = SCM_CAAR (env);
- SCM values = SCM_CDAR (env);
- while (scm_is_pair (names))
- {
- if (scm_is_eq (SCM_CAR (values), data))
- return SCM_CAR (names);
- names = SCM_CDR (names);
- values = SCM_CDR (values);
- }
- if (!scm_is_null (names) && scm_is_eq (values, data))
- return names;
- env = SCM_CDR (env);
- }
- return SCM_BOOL_F;
-}
-
-SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
- (SCM id, SCM thunk),
- "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
-#define FUNC_NAME s_scm_sys_start_stack
-{
- SCM answer;
- scm_t_debug_frame vframe;
- scm_t_debug_info vframe_vect_body;
- vframe.prev = scm_i_last_debug_frame ();
- vframe.status = SCM_VOIDFRAME;
- vframe.vect = &vframe_vect_body;
- vframe.vect[0].id = id;
- scm_i_set_last_debug_frame (&vframe);
- answer = scm_call_0 (thunk);
- scm_i_set_last_debug_frame (vframe.prev);
- return answer;
-}
-#undef FUNC_NAME
-
-/* {Debug Objects}
- *
- * The debugging evaluator throws these on frame traps.
- */
-
-scm_t_bits scm_tc16_debugobj;
-
-static int
-debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<debug-object ", port);
- scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port);
- scm_putc ('>', port);
- return 1;
-}
-
-SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a debug object.")
-#define FUNC_NAME s_scm_debug_object_p
-{
- return scm_from_bool(SCM_DEBUGOBJP (obj));
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_make_debugobj (scm_t_debug_frame *frame)
-{
- return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame);
-}
-
-\f
-
-/* Undocumented debugging procedure */
-#ifdef GUILE_DEBUG
-SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
- (SCM obj),
- "Go into an endless loop, which can be only terminated with\n"
- "a debugger.")
-#define FUNC_NAME s_scm_debug_hang
-{
- int go = 0;
- while (!go) ;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-#endif
-
-static void
-init_stack_limit (void)
-{
-#ifdef HAVE_GETRLIMIT
- struct rlimit lim;
- if (getrlimit (RLIMIT_STACK, &lim) == 0)
- {
- rlim_t bytes = lim.rlim_cur;
-
- /* set our internal stack limit to 80% of the rlimit. */
- if (bytes == RLIM_INFINITY)
- bytes = lim.rlim_max;
-
- if (bytes != RLIM_INFINITY)
- SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
- }
- errno = 0;
-#endif
-}
-
-\f
-
-void
-scm_init_debug ()
-{
- init_stack_limit ();
- scm_init_opts (scm_debug_options, scm_debug_opts);
-
- scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
- scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
- scm_set_smob_print (scm_tc16_memoized, memoized_print);
-
- scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
- scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
-
-#ifdef GUILE_DEBUG
- scm_c_define ("SCM_IM_AND", SCM_IM_AND);
- scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
- scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
- scm_c_define ("SCM_IM_COND", SCM_IM_COND);
- scm_c_define ("SCM_IM_DO", SCM_IM_DO);
- scm_c_define ("SCM_IM_IF", SCM_IM_IF);
- scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
- scm_c_define ("SCM_IM_LET", SCM_IM_LET);
- scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
- scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
- scm_c_define ("SCM_IM_OR", SCM_IM_OR);
- scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
- scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
- scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
- scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
- scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
- scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
-#endif
- scm_add_feature ("debug-extensions");
-
-#include "libguile/debug.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Debugging extensions for Guile
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 Free Software Foundation
+ *
+ * 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
+
+#ifdef HAVE_GETRLIMIT
+#include <sys/time.h>
+#include <sys/resource.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/eval.h"
+#include "libguile/list.h"
+#include "libguile/stackchk.h"
+#include "libguile/throw.h"
+#include "libguile/macros.h"
+#include "libguile/smob.h"
+#include "libguile/procprop.h"
+#include "libguile/srcprop.h"
+#include "libguile/alist.h"
+#include "libguile/continuations.h"
+#include "libguile/strports.h"
+#include "libguile/read.h"
+#include "libguile/feature.h"
+#include "libguile/dynwind.h"
+#include "libguile/modules.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/fluids.h"
+#include "libguile/programs.h"
+#include "libguile/memoize.h"
+#include "libguile/vm.h"
+
+#include "libguile/validate.h"
+#include "libguile/debug.h"
+
+#include "libguile/private-options.h"
+\f
+
+
+/* {Run time control of the debugging evaluator}
+ */
+
+SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the debug options. Instead of using\n"
+ "this procedure directly, use the procedures @code{debug-enable},\n"
+ "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
+#define FUNC_NAME s_scm_debug_options
+{
+ SCM ans;
+
+ scm_dynwind_begin (0);
+ scm_dynwind_critical_section (SCM_BOOL_F);
+
+ ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
+ if (SCM_N_FRAMES < 1)
+ {
+ scm_options (ans, scm_debug_opts, FUNC_NAME);
+ SCM_OUT_OF_RANGE (1, setting);
+ }
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
+
+ scm_dynwind_end ();
+ return ans;
+}
+#undef FUNC_NAME
+
+
+static void
+with_traps_before (void *data)
+{
+ int *trap_flag = data;
+ *trap_flag = SCM_TRAPS_P;
+ SCM_TRAPS_P = 1;
+}
+
+static void
+with_traps_after (void *data)
+{
+ int *trap_flag = data;
+ SCM_TRAPS_P = *trap_flag;
+}
+
+static SCM
+with_traps_inner (void *data)
+{
+ SCM thunk = SCM_PACK ((scm_t_bits) data);
+ return scm_call_0 (thunk);
+}
+
+SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
+ (SCM thunk),
+ "Call @var{thunk} with traps enabled.")
+#define FUNC_NAME s_scm_with_traps
+{
+ int trap_flag;
+ SCM_VALIDATE_THUNK (1, thunk);
+ return scm_internal_dynamic_wind (with_traps_before,
+ with_traps_inner,
+ with_traps_after,
+ (void *) SCM_UNPACK (thunk),
+ &trap_flag);
+}
+#undef FUNC_NAME
+
+\f
+SCM_SYMBOL (scm_sym_procname, "procname");
+SCM_SYMBOL (scm_sym_dots, "...");
+SCM_SYMBOL (scm_sym_source, "source");
+
+SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
+ (SCM proc),
+ "Return the name of the procedure @var{proc}")
+#define FUNC_NAME s_scm_procedure_name
+{
+ SCM_VALIDATE_PROC (1, proc);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tc7_gsubr:
+ return SCM_SUBR_NAME (proc);
+ default:
+ {
+ SCM name = scm_procedure_property (proc, scm_sym_name);
+ if (scm_is_false (name) && SCM_PROGRAM_P (proc))
+ name = scm_program_name (proc);
+ return name;
+ }
+ }
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
+ (SCM proc),
+ "Return the source of the procedure @var{proc}.")
+#define FUNC_NAME s_scm_procedure_source
+{
+ SCM src;
+ SCM_VALIDATE_PROC (1, proc);
+
+ do
+ {
+ src = scm_procedure_property (proc, scm_sym_source);
+ if (scm_is_true (src))
+ return src;
+
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_struct:
+ if (!SCM_STRUCT_APPLICABLE_P (proc)
+ || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
+ break;
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ continue;
+ default:
+ break;
+ }
+ }
+ while (0);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+\f
+
+#if 0
+SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
+#endif
+
+SCM
+scm_reverse_lookup (SCM env, SCM data)
+{
+ while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
+ {
+ SCM names = SCM_CAAR (env);
+ SCM values = SCM_CDAR (env);
+ while (scm_is_pair (names))
+ {
+ if (scm_is_eq (SCM_CAR (values), data))
+ return SCM_CAR (names);
+ names = SCM_CDR (names);
+ values = SCM_CDR (values);
+ }
+ if (!scm_is_null (names) && scm_is_eq (values, data))
+ return names;
+ env = SCM_CDR (env);
+ }
+ return SCM_BOOL_F;
+}
+
+SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
+ (SCM id, SCM thunk),
+ "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
+#define FUNC_NAME s_scm_sys_start_stack
+{
+ return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id);
+}
+#undef FUNC_NAME
+
+\f
+
+/* Undocumented debugging procedure */
+#ifdef GUILE_DEBUG
+SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
+ (SCM obj),
+ "Go into an endless loop, which can be only terminated with\n"
+ "a debugger.")
+#define FUNC_NAME s_scm_debug_hang
+{
+ int go = 0;
+ while (!go) ;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+static void
+init_stack_limit (void)
+{
+#ifdef HAVE_GETRLIMIT
+ struct rlimit lim;
+ if (getrlimit (RLIMIT_STACK, &lim) == 0)
+ {
+ rlim_t bytes = lim.rlim_cur;
+
+ /* set our internal stack limit to 80% of the rlimit. */
+ if (bytes == RLIM_INFINITY)
+ bytes = lim.rlim_max;
+
+ if (bytes != RLIM_INFINITY)
+ SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
+ }
+ errno = 0;
+#endif
+}
+
+\f
+
+void
+scm_init_debug ()
+{
+ init_stack_limit ();
+ scm_init_opts (scm_debug_options, scm_debug_opts);
+
+ scm_add_feature ("debug-extensions");
+
+#include "libguile/debug.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* classes: h_files */
-
-#ifndef SCM_DEBUG_H
-#define SCM_DEBUG_H
-
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,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
- */
-
-\f
-
-#include "libguile/__scm.h"
-
-#include "libguile/options.h"
-\f
-
-/*
- * Here comes some definitions for the debugging machinery.
- * It might seem strange to represent debug flags as ints,
- * but consider that any particular piece of code is normally
- * only interested in one flag at a time. This is then
- * the most efficient representation.
- */
-
-/* {Options}
- */
-
-/* scm_debug_opts is defined in eval.c.
- */
-
-
-
-SCM_API int scm_debug_mode_p;
-SCM_API int scm_check_entry_p;
-SCM_API int scm_check_apply_p;
-SCM_API int scm_check_exit_p;
-SCM_API int scm_check_memoize_p;
-
-#define SCM_RESET_DEBUG_MODE \
-do {\
- scm_check_entry_p = (SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P)\
- && scm_is_true (SCM_ENTER_FRAME_HDLR);\
- scm_check_apply_p = (SCM_APPLY_FRAME_P || SCM_TRACE_P)\
- && scm_is_true (SCM_APPLY_FRAME_HDLR);\
- scm_check_exit_p = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\
- && scm_is_true (SCM_EXIT_FRAME_HDLR);\
- scm_check_memoize_p = (SCM_MEMOIZE_P)\
- && scm_is_true (SCM_MEMOIZE_HDLR);\
- scm_debug_mode_p = SCM_DEVAL_P\
- || scm_check_memoize_p || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\
-} while (0)
-
-/* {Evaluator}
- */
-
-typedef union scm_t_debug_info
-{
- struct { SCM exp, env; } e;
- struct { SCM proc, args; } a;
- SCM id;
-} scm_t_debug_info;
-
-SCM_API long scm_debug_eframe_size;
-
-typedef struct scm_t_debug_frame
-{
- struct scm_t_debug_frame *prev;
- long status;
- scm_t_debug_info *vect;
- scm_t_debug_info *info;
-} scm_t_debug_frame;
-
-#define SCM_EVALFRAME (0L << 11)
-#define SCM_APPLYFRAME (1L << 11)
-#define SCM_VOIDFRAME (3L << 11)
-#define SCM_MACROEXPF (1L << 10)
-#define SCM_TAILREC (1L << 9)
-#define SCM_TRACED_FRAME (1L << 8)
-#define SCM_ARGS_READY (1L << 7)
-#define SCM_DOVERFLOW (1L << 6)
-#define SCM_MAX_FRAME_SIZE 63
-
-#define SCM_FRAMETYPE (3L << 11)
-
-#define SCM_EVALFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_EVALFRAME)
-#define SCM_APPLYFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_APPLYFRAME)
-#define SCM_VOIDFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_VOIDFRAME)
-#define SCM_OVERFLOWP(x) (((x).status & SCM_DOVERFLOW) != 0)
-#define SCM_ARGS_READY_P(x) (((x).status & SCM_ARGS_READY) != 0)
-#define SCM_TRACED_FRAME_P(x) (((x).status & SCM_TRACED_FRAME) != 0)
-#define SCM_TAILRECP(x) (((x).status & SCM_TAILREC) != 0)
-#define SCM_MACROEXPP(x) (((x).status & SCM_MACROEXPF) != 0)
-#define SCM_SET_OVERFLOW(x) ((x).status |= SCM_DOVERFLOW)
-#define SCM_SET_ARGSREADY(x) ((x).status |= SCM_ARGS_READY)
-#define SCM_CLEAR_ARGSREADY(x) ((x).status &= ~SCM_ARGS_READY)
-#define SCM_SET_TRACED_FRAME(x) ((x).status |= SCM_TRACED_FRAME)
-#define SCM_CLEAR_TRACED_FRAME(x) ((x).status &= ~SCM_TRACED_FRAME)
-#define SCM_SET_TAILREC(x) ((x).status |= SCM_TAILREC)
-#define SCM_SET_MACROEXP(x) ((x).status |= SCM_MACROEXPF)
-#define SCM_CLEAR_MACROEXP(x) ((x).status &= ~SCM_MACROEXPF)
-
-/* {Debug Objects}
- */
-
-SCM_API scm_t_bits scm_tc16_debugobj;
-
-#define SCM_DEBUGOBJP(x) \
- SCM_TYP16_PREDICATE (scm_tc16_debugobj, x)
-#define SCM_DEBUGOBJ_FRAME(x) \
- ((scm_t_debug_frame *) SCM_CELL_WORD_1 (x))
-#define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SET_CELL_WORD_1 (x, f)
-
-/* {Memoized Source}
- */
-
-SCM_API scm_t_bits scm_tc16_memoized;
-
-#define SCM_MEMOIZEDP(x) SCM_TYP16_PREDICATE (scm_tc16_memoized, x)
-#define SCM_MEMOIZED_EXP(x) SCM_CAR (SCM_CELL_OBJECT_1 (x))
-#define SCM_MEMOIZED_ENV(x) SCM_CDR (SCM_CELL_OBJECT_1 (x))
-
-\f
-
-SCM_API SCM scm_debug_object_p (SCM obj);
-SCM_API SCM scm_local_eval (SCM exp, SCM env);
-SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
-SCM_API SCM scm_procedure_environment (SCM proc);
-SCM_API SCM scm_procedure_module (SCM proc);
-SCM_API SCM scm_procedure_source (SCM proc);
-SCM_API SCM scm_procedure_name (SCM proc);
-SCM_API SCM scm_memoized_environment (SCM m);
-SCM_API SCM scm_make_memoized (SCM exp, SCM env);
-SCM_API SCM scm_memoized_p (SCM obj);
-SCM_API SCM scm_with_traps (SCM thunk);
-SCM_API SCM scm_evaluator_traps (SCM setting);
-SCM_API SCM scm_debug_options (SCM setting);
-SCM_API SCM scm_make_debugobj (scm_t_debug_frame *debug);
-
-SCM_INTERNAL SCM scm_i_unmemoize_expr (SCM memoized);
-SCM_INTERNAL void scm_init_debug (void);
-
-#ifdef GUILE_DEBUG
-SCM_API SCM scm_memcons (SCM car, SCM cdr, SCM env);
-SCM_API SCM scm_mem_to_proc (SCM obj);
-SCM_API SCM scm_proc_to_mem (SCM obj);
-SCM_API SCM scm_debug_hang (SCM obj);
-#endif /*GUILE_DEBUG*/
-
-#if SCM_ENABLE_DEPRECATED == 1
-
-#define CHECK_ENTRY scm_check_entry_p
-#define CHECK_APPLY scm_check_apply_p
-#define CHECK_EXIT scm_check_exit_p
-
-/* Deprecated in guile 1.7.0 on 2004-03-29. */
-#define SCM_DEBUGGINGP scm_debug_mode_p
-#define scm_debug_mode scm_debug_mode_p
-
-#endif
-
-#endif /* SCM_DEBUG_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* classes: h_files */
+
+#ifndef SCM_DEBUG_H
+#define SCM_DEBUG_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
+ * 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/options.h"
+\f
+
+/* {Evaluator}
+ */
+
+typedef union scm_t_debug_info
+{
+ struct { SCM exp, env; } e;
+ struct { SCM proc, args; } a;
+ SCM id;
+} scm_t_debug_info;
+
+\f
+
+SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
+SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
+SCM_API SCM scm_procedure_source (SCM proc);
+SCM_API SCM scm_procedure_name (SCM proc);
+SCM_API SCM scm_with_traps (SCM thunk);
+SCM_API SCM scm_evaluator_traps (SCM setting);
+SCM_API SCM scm_debug_options (SCM setting);
+
+SCM_INTERNAL void scm_init_debug (void);
+
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_debug_hang (SCM obj);
+#endif /*GUILE_DEBUG*/
+
+#if SCM_ENABLE_DEPRECATED == 1
+
+#define CHECK_ENTRY scm_check_entry_p
+#define CHECK_APPLY scm_check_apply_p
+#define CHECK_EXIT scm_check_exit_p
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+#define SCM_DEBUGGINGP scm_debug_mode_p
+#define scm_debug_mode scm_debug_mode_p
+
+#endif
+
+#endif /* SCM_DEBUG_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
deprecate something, move it here when that is feasible.
*/
-/* Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2003, 2004, 2006, 2008, 2009 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
# include <config.h>
#endif
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/deprecated.h"
#include "libguile/smob.h"
#include "libguile/alist.h"
#include "libguile/keywords.h"
+#include "libguile/socket.h"
#include "libguile/feature.h"
+#include <math.h>
#include <stdio.h>
#include <string.h>
+#include <arpa/inet.h>
+
#if (SCM_ENABLE_DEPRECATED == 1)
/* From print.c: Internal symbol names of isyms. Deprecated in guile 1.7.0 on
};
-/* From eval.c: Error messages of the evaluator. These were deprecated in
- * guile 1.7.0 on 2003-06-02. */
-const char scm_s_expression[] = "missing or extra expression";
-const char scm_s_test[] = "bad test";
-const char scm_s_body[] = "bad body";
-const char scm_s_bindings[] = "bad bindings";
-const char scm_s_variable[] = "bad variable";
-const char scm_s_clauses[] = "bad or missing clauses";
-const char scm_s_formals[] = "bad formals";
-
-
SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
static void
init_module_stuff ()
{
-#define PERM(x) scm_permanent_object(x)
-
if (module_prefix == SCM_BOOL_F)
{
- module_prefix = PERM (scm_list_2 (scm_sym_app, scm_sym_modules));
- make_modules_in_var = PERM (scm_c_lookup ("make-modules-in"));
+ module_prefix = scm_list_2 (scm_sym_app, scm_sym_modules);
+ make_modules_in_var = scm_c_lookup ("make-modules-in");
beautify_user_module_x_var =
- PERM (scm_c_lookup ("beautify-user-module!"));
- try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload"));
+ scm_c_lookup ("beautify-user-module!");
+ try_module_autoload_var = scm_c_lookup ("try-module-autoload");
}
}
-SCM
-scm_the_root_module ()
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. "
- "Use `scm_c_resolve_module (\"guile\")' "
- "instead.");
-
- return scm_c_resolve_module ("guile");
-}
-
static SCM
scm_module_full_name (SCM name)
{
{
SCM hook = scm_make_hook (scm_from_int (n_args));
scm_c_define (name, hook);
- return scm_permanent_object (hook);
+ return hook;
}
}
if (equalp) scm_set_smob_equalp (tc, equalp);
}
+size_t
+scm_smob_free (SCM obj)
+{
+ long n = SCM_SMOBNUM (obj);
+
+ scm_c_issue_deprecation_warning
+ ("`scm_smob_free' is deprecated. "
+ "It is no longer needed.");
+
+ if (scm_smobs[n].size > 0)
+ scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj),
+ scm_smobs[n].size, SCM_SMOBNAME (n));
+ return 0;
+}
+
SCM
scm_read_0str (char *expr)
{
return scm_c_round (x);
}
+SCM
+scm_sys_expt (SCM x, SCM y)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_sys_expt is deprecated. Use scm_expt instead.");
+ return scm_expt (x, y);
+}
+
+double
+scm_asinh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_asinh is deprecated. Use asinh instead.");
+#if HAVE_ASINH
+ return asinh (x);
+#else
+ return log (x + sqrt (x * x + 1));
+#endif
+}
+
+double
+scm_acosh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_acosh is deprecated. Use acosh instead.");
+#if HAVE_ACOSH
+ return acosh (x);
+#else
+ return log (x + sqrt (x * x - 1));
+#endif
+}
+
+double
+scm_atanh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_atanh is deprecated. Use atanh instead.");
+#if HAVE_ATANH
+ return atanh (x);
+#else
+ return 0.5 * log ((1 + x) / (1 - x));
+#endif
+}
+
+SCM
+scm_sys_atan2 (SCM z1, SCM z2)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_sys_atan2 is deprecated. Use scm_atan instead.");
+ return scm_atan (z1, z2);
+}
+
char *
scm_i_deprecated_symbol_chars (SCM sym)
{
return scm_i_dynwinds ();
}
-scm_t_debug_frame *
-scm_i_deprecated_last_debug_frame (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_last_debug_frame is deprecated. Do not use it.");
- return scm_i_last_debug_frame ();
-}
-
SCM_STACKITEM *
scm_i_stack_base (void)
{
return scm_is_fluid (x);
}
+\f
+/* Networking. */
+
+#ifdef HAVE_NETWORKING
+
+SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0,
+ (SCM address),
+ "Convert an IPv4 Internet address from printable string\n"
+ "(dotted decimal notation) to an integer. E.g.,\n\n"
+ "@lisp\n"
+ "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_inet_aton
+{
+ scm_c_issue_deprecation_warning
+ ("`inet-aton' is deprecated. Use `inet-pton' instead.");
+
+ return scm_inet_pton (scm_from_int (AF_INET), address);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0,
+ (SCM inetid),
+ "Convert an IPv4 Internet address to a printable\n"
+ "(dotted decimal notation) string. E.g.,\n\n"
+ "@lisp\n"
+ "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_inet_ntoa
+{
+ scm_c_issue_deprecation_warning
+ ("`inet-ntoa' is deprecated. Use `inet-ntop' instead.");
+
+ return scm_inet_ntop (scm_from_int (AF_INET), inetid);
+}
+#undef FUNC_NAME
+
+#endif /* HAVE_NETWORKING */
+
+\f
void
scm_i_defer_ints_etc ()
{
"Use a mutex instead if appropriate.");
}
+int
+scm_i_mask_ints (void)
+{
+ scm_c_issue_deprecation_warning ("`scm_mask_ints' is deprecated.");
+ return (SCM_I_CURRENT_THREAD->block_asyncs != 0);
+}
+
+\f
SCM
scm_guard (SCM guardian, SCM obj, int throw_p)
{
}
#undef FUNC_NAME
+\f
+/* GC-related things. */
+
+unsigned long scm_mallocated, scm_mtrigger;
+size_t scm_max_segment_size;
+
+#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
+SCM
+scm_map_free_list (void)
+{
+ return SCM_EOL;
+}
+#endif
+
+#if defined (GUILE_DEBUG_FREELIST)
+SCM
+scm_gc_set_debug_check_freelist_x (SCM flag)
+{
+ return SCM_UNSPECIFIED;
+}
+#endif
+
+\f
+/* Trampolines
+ *
+ * Trampolines were an intent to speed up calling the same Scheme procedure many
+ * times from C.
+ *
+ * However, this was the wrong thing to optimize; if you really know what you're
+ * calling, call its function directly, otherwise you're in Scheme-land, and we
+ * have many better tricks there (inlining, for example, which can remove the
+ * need for closures and free variables).
+ *
+ * Also, in the normal debugging case, trampolines were being computed but not
+ * used. Silliness.
+ */
+
+scm_t_trampoline_0
+scm_trampoline_0 (SCM proc)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_trampoline_0' is deprecated. Just use `scm_call_0' instead.");
+ return scm_call_0;
+}
+
+scm_t_trampoline_1
+scm_trampoline_1 (SCM proc)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_trampoline_1' is deprecated. Just use `scm_call_1' instead.");
+ return scm_call_1;
+}
+
+scm_t_trampoline_2
+scm_trampoline_2 (SCM proc)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_trampoline_2' is deprecated. Just use `scm_call_2' instead.");
+ return scm_call_2;
+}
+
+\f
void
scm_i_init_deprecated ()
{
#include "libguile/__scm.h"
#include "libguile/arrays.h"
#include "libguile/strings.h"
+#include "libguile/eval.h"
#if (SCM_ENABLE_DEPRECATED == 1)
#define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex)
-/* From eval.h: Macros for handling ilocs. These were deprecated in guile
- * 1.7.0 on 2003-06-04. */
-#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
-#define SCM_IDINC (0x00100000L)
-#define SCM_IDSTMSK (-SCM_IDINC)
-
-
-/* From eval.h: Error messages of the evaluator. These were deprecated in
- * guile 1.7.0 on 2003-06-02. */
-SCM_API const char scm_s_expression[];
-SCM_API const char scm_s_test[];
-SCM_API const char scm_s_body[];
-SCM_API const char scm_s_bindings[];
-SCM_API const char scm_s_variable[];
-SCM_API const char scm_s_clauses[];
-SCM_API const char scm_s_formals[];
-
-
-/* From eval.h: Helper macros for evaluation and application. These were
- * deprecated in guile 1.7.0 on 2003-06-02. */
-#define SCM_EVALIM2(x) \
- ((scm_is_eq ((x), SCM_EOL) \
- ? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \
- : 0), \
- (x))
-#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
- ? *scm_ilookup ((x), env) \
- : SCM_EVALIM2(x))
-#define SCM_XEVAL(x, env) (scm_i_eval_x ((x), (env)))
-#define SCM_XEVALCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
- ? *scm_lookupcar (x, env, 1) \
- : scm_i_eval_x (SCM_CAR (x), (env)))
-
+/* From structs.h:
+ Deprecated in Guile 1.9.5 on 2009-11-03. */
+#define scm_vtable_index_vtable scm_vtable_index_self
+#define scm_vtable_index_printer scm_vtable_index_instance_printer
+#define scm_struct_i_free scm_vtable_index_instance_finalize
+#define scm_struct_i_flags scm_vtable_index_flags
+#define SCM_STRUCTF_MASK ((scm_t_bits)-1)
+#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA(x)[scm_struct_i_free]=(scm_t_bits)(D))
#define scm_substring_move_left_x scm_substring_move_x
#define scm_substring_move_right_x scm_substring_move_x
#define scm_sizet size_t
-SCM_API SCM scm_wta (SCM arg, const char *pos, const char *s_subr);
+SCM_DEPRECATED SCM scm_wta (SCM arg, const char *pos, const char *s_subr);
#define SCM_WNA 8
#define SCM_OUTOFRANGE 10
#define SCM_NALLOC 11
-SCM_API void scm_register_module_xxx (char *module_name, void *init_func);
-SCM_API SCM scm_registered_modules (void);
-SCM_API SCM scm_clear_registered_modules (void);
+SCM_DEPRECATED void scm_register_module_xxx (char *module_name, void *init_func);
+SCM_DEPRECATED SCM scm_registered_modules (void);
+SCM_DEPRECATED SCM scm_clear_registered_modules (void);
-SCM_API SCM scm_protect_object (SCM obj);
-SCM_API SCM scm_unprotect_object (SCM obj);
+SCM_DEPRECATED SCM scm_protect_object (SCM obj);
+SCM_DEPRECATED SCM scm_unprotect_object (SCM obj);
#define SCM_SETAND_CAR(x, y) \
(SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y))))
(SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y))))
#define SCM_SETOR_CDR(x, y)\
(SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y))))
-#define SCM_FREEP(x) (SCM_FREE_CELL_P (x))
-#define SCM_NFREEP(x) (!SCM_FREE_CELL_P (x))
-#define SCM_GC8MARKP(x) SCM_GC_MARK_P (x)
-#define SCM_SETGC8MARK(x) SCM_SET_GC_MARK (x)
-#define SCM_CLRGC8MARK(x) SCM_CLEAR_GC_MARK (x)
+#define SCM_FREEP(x) (0)
+#define SCM_NFREEP(x) (1)
#define SCM_GCTYP16(x) SCM_TYP16 (x)
#define SCM_GCCDR(x) SCM_CDR (x)
-SCM_API void scm_remember (SCM * ptr);
+SCM_DEPRECATED void scm_remember (SCM * ptr);
-SCM_API SCM scm_the_root_module (void);
-SCM_API SCM scm_make_module (SCM name);
-SCM_API SCM scm_ensure_user_module (SCM name);
-SCM_API SCM scm_load_scheme_module (SCM name);
+SCM_DEPRECATED SCM scm_make_module (SCM name);
+SCM_DEPRECATED SCM scm_ensure_user_module (SCM name);
+SCM_DEPRECATED SCM scm_load_scheme_module (SCM name);
#define scm_port scm_t_port
#define scm_ptob_descriptor scm_t_ptob_descriptor
#define scm_port_rw_active scm_t_port_rw_active
-SCM_API SCM scm_close_all_ports_except (SCM ports);
+SCM_DEPRECATED SCM scm_close_all_ports_except (SCM ports);
#define scm_rstate scm_t_rstate
#define scm_rng scm_t_rng
#define scm_tc7_msymbol scm_tc7_symbol
#define scm_tcs_symbols scm_tc7_symbol
-SCM_API SCM scm_makstr (size_t len, int);
-SCM_API SCM scm_makfromstr (const char *src, size_t len, int);
+SCM_DEPRECATED SCM scm_makstr (size_t len, int);
+SCM_DEPRECATED SCM scm_makfromstr (const char *src, size_t len, int);
-SCM_API SCM scm_variable_set_name_hint (SCM var, SCM hint);
-SCM_API SCM scm_builtin_variable (SCM name);
+SCM_DEPRECATED SCM scm_variable_set_name_hint (SCM var, SCM hint);
+SCM_DEPRECATED SCM scm_builtin_variable (SCM name);
-SCM_API SCM scm_internal_with_fluids (SCM fluids, SCM vals,
- SCM (*cproc)(void *), void *cdata);
+SCM_DEPRECATED SCM scm_internal_with_fluids (SCM fluids, SCM vals,
+ SCM (*cproc)(void *),
+ void *cdata);
-SCM_API SCM scm_make_gsubr (const char *name, int req, int opt, int rst,
- SCM (*fcn)());
-SCM_API SCM scm_make_gsubr_with_generic (const char *name,
- int req,
- int opt,
- int rst,
- SCM (*fcn)(),
- SCM *gf);
+SCM_DEPRECATED SCM scm_make_gsubr (const char *name,
+ int req, int opt, int rst,
+ SCM (*fcn)());
+SCM_DEPRECATED SCM scm_make_gsubr_with_generic (const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf);
-SCM_API SCM scm_create_hook (const char* name, int n_args);
+SCM_DEPRECATED SCM scm_create_hook (const char* name, int n_args);
#define SCM_LIST0 SCM_EOL
#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
#define scm_listify scm_list_n
-SCM_API SCM scm_sloppy_memq (SCM x, SCM lst);
-SCM_API SCM scm_sloppy_memv (SCM x, SCM lst);
-SCM_API SCM scm_sloppy_member (SCM x, SCM lst);
+SCM_DEPRECATED SCM scm_sloppy_memq (SCM x, SCM lst);
+SCM_DEPRECATED SCM scm_sloppy_memv (SCM x, SCM lst);
+SCM_DEPRECATED SCM scm_sloppy_member (SCM x, SCM lst);
-SCM_API SCM scm_read_and_eval_x (SCM port);
+SCM_DEPRECATED SCM scm_read_and_eval_x (SCM port);
#define scm_subr_entry scm_t_subr_entry
#define SCM_SUBR_DOC(x) SCM_BOOL_F
-SCM_API SCM scm_make_subr (const char *name, int type, SCM (*fcn) ());
-SCM_API SCM scm_make_subr_with_generic (const char *name,
- int type,
- SCM (*fcn) (),
- SCM *gf);
-SCM_API SCM scm_make_subr_opt (const char *name,
- int type,
- SCM (*fcn) (),
- int set);
-
-SCM_API SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(),
- void * closure);
-
-SCM_API long scm_make_smob_type_mfpe (char *name, size_t size,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM,
- scm_print_state*),
- SCM (*equalp) (SCM, SCM));
-
-SCM_API void scm_set_smob_mfpe (long tc,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM, scm_print_state*),
- SCM (*equalp) (SCM, SCM));
-
-SCM_API SCM scm_strprint_obj (SCM obj);
-SCM_API SCM scm_read_0str (char *expr);
-SCM_API SCM scm_eval_0str (const char *expr);
-
-SCM_API char *scm_i_object_chars (SCM);
+SCM_DEPRECATED SCM scm_make_subr (const char *name, int type, SCM (*fcn) ());
+SCM_DEPRECATED SCM scm_make_subr_with_generic (const char *name,
+ int type,
+ SCM (*fcn) (),
+ SCM *gf);
+SCM_DEPRECATED SCM scm_make_subr_opt (const char *name,
+ int type,
+ SCM (*fcn) (),
+ int set);
+
+SCM_DEPRECATED SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(),
+ void * closure);
+
+SCM_DEPRECATED long scm_make_smob_type_mfpe (char *name, size_t size,
+ SCM (*mark) (SCM),
+ size_t (*free) (SCM),
+ int (*print) (SCM, SCM,
+ scm_print_state*),
+ SCM (*equalp) (SCM, SCM));
+
+SCM_DEPRECATED void scm_set_smob_mfpe (long tc,
+ SCM (*mark) (SCM),
+ size_t (*free) (SCM),
+ int (*print) (SCM, SCM, scm_print_state*),
+ SCM (*equalp) (SCM, SCM));
+
+SCM_DEPRECATED size_t scm_smob_free (SCM obj);
+
+SCM_DEPRECATED SCM scm_strprint_obj (SCM obj);
+SCM_DEPRECATED SCM scm_read_0str (char *expr);
+SCM_DEPRECATED SCM scm_eval_0str (const char *expr);
+
+SCM_DEPRECATED char *scm_i_object_chars (SCM);
#define SCM_CHARS(x) scm_i_object_chars(x)
#define SCM_UCHARS(x) ((unsigned char *)SCM_CHARS(x))
-SCM_API long scm_i_object_length (SCM);
+SCM_DEPRECATED long scm_i_object_length (SCM);
#define SCM_LENGTH(x) scm_i_object_length(x)
#define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n))
-SCM_API SCM scm_sym2ovcell_soft (SCM sym, SCM obarray);
-SCM_API SCM scm_sym2ovcell (SCM sym, SCM obarray);
-SCM_API SCM scm_intern_obarray_soft (const char *name, size_t len,
+SCM_DEPRECATED SCM scm_sym2ovcell_soft (SCM sym, SCM obarray);
+SCM_DEPRECATED SCM scm_sym2ovcell (SCM sym, SCM obarray);
+SCM_DEPRECATED SCM scm_intern_obarray_soft (const char *name, size_t len,
SCM obarray, unsigned int softness);
-SCM_API SCM scm_intern_obarray (const char *name, size_t len, SCM obarray);
-SCM_API SCM scm_symbol_value0 (const char *name);
+SCM_DEPRECATED SCM scm_intern_obarray (const char *name, size_t len, SCM obarray);
+SCM_DEPRECATED SCM scm_symbol_value0 (const char *name);
-SCM_API SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp);
-SCM_API SCM scm_intern_symbol (SCM o, SCM s);
-SCM_API SCM scm_unintern_symbol (SCM o, SCM s);
-SCM_API SCM scm_symbol_binding (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp);
+SCM_DEPRECATED SCM scm_intern_symbol (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_unintern_symbol (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_symbol_binding (SCM o, SCM s);
#if 0
/* This name has been reused for real uninterned symbols. */
-SCM_API SCM scm_symbol_interned_p (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_symbol_interned_p (SCM o, SCM s);
#endif
-SCM_API SCM scm_symbol_bound_p (SCM o, SCM s);
-SCM_API SCM scm_symbol_set_x (SCM o, SCM s, SCM v);
+SCM_DEPRECATED SCM scm_symbol_bound_p (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_symbol_set_x (SCM o, SCM s, SCM v);
-SCM_API SCM scm_gentemp (SCM prefix, SCM obarray);
+SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray);
#define SCM_OPDIRP(x) (SCM_DIRP (x) && (SCM_DIR_OPEN_P (x)))
#define scm_fport scm_t_fport
#define scm_option scm_t_option
#define scm_srcprops scm_t_srcprops
#define scm_srcprops_chunk scm_t_srcprops_chunk
-#define scm_info_frame scm_t_info_frame
-#define scm_stack scm_t_stack
#define scm_array scm_t_array
#define scm_array_dim scm_t_array_dim
#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS
/* Users shouldn't know about INUMs.
*/
-SCM_API SCM scm_i_makinum (scm_t_signed_bits val);
-SCM_API int scm_i_inump (SCM obj);
-SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
+SCM_DEPRECATED SCM scm_i_makinum (scm_t_signed_bits val);
+SCM_DEPRECATED int scm_i_inump (SCM obj);
+SCM_DEPRECATED scm_t_signed_bits scm_i_inum (SCM obj);
#define SCM_MAKINUM(x) scm_i_makinum(x)
#define SCM_INUM(x) scm_i_inum(x)
copies the complete contents of OBJ, and sets *LENP to the length of the
scheme string (if LENP is non-null).
*/
-SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp);
+SCM_DEPRECATED char *scm_c_string2str (SCM obj, char *str, size_t *lenp);
/* XXX - buggy interface, you don't know how many bytes have been copied.
region to fit the string. If truncation occurs, the corresponding
area of STR is left unchanged.
*/
-SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len);
+SCM_DEPRECATED char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len);
-SCM_API char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp);
+SCM_DEPRECATED char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp);
/* Deprecated because the names belong to what is now
scm_truncate_number and scm_round_number.
*/
-SCM_API double scm_truncate (double x);
-SCM_API double scm_round (double x);
+SCM_DEPRECATED double scm_truncate (double x);
+SCM_DEPRECATED double scm_round (double x);
+/* Deprecated, use scm_expt */
+SCM_DEPRECATED SCM scm_sys_expt (SCM x, SCM y);
+
+/* if your platform doesn't have asinh et al */
+SCM_API double scm_asinh (double x);
+SCM_API double scm_acosh (double x);
+SCM_API double scm_atanh (double x);
+SCM_API SCM scm_sys_atan2 (SCM z1, SCM z2);
/* Deprecated because we don't want people to access the internal
representation of strings directly.
symbols directly.
*/
-SCM_API char *scm_i_deprecated_symbol_chars (SCM sym);
-SCM_API size_t scm_i_deprecated_symbol_length (SCM sym);
+SCM_DEPRECATED char *scm_i_deprecated_symbol_chars (SCM sym);
+SCM_DEPRECATED size_t scm_i_deprecated_symbol_length (SCM sym);
#define SCM_SYMBOL_CHARS(x) scm_i_deprecated_symbol_chars(x)
#define SCM_SYMBOL_LENGTH(x) scm_i_deprecated_symbol_length(x)
than once and because the symbol of a keyword now has no dash.
*/
-SCM_API int scm_i_keywordp (SCM obj);
-SCM_API SCM scm_i_keywordsym (SCM keyword);
+SCM_DEPRECATED int scm_i_keywordp (SCM obj);
+SCM_DEPRECATED SCM scm_i_keywordsym (SCM keyword);
#define SCM_KEYWORDP(x) scm_i_keywordp(x)
#define SCM_KEYWORDSYM(x) scm_i_keywordsym(x)
#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1)
-SCM_API int scm_i_vectorp (SCM x);
-SCM_API unsigned long scm_i_vector_length (SCM x);
-SCM_API const SCM *scm_i_velts (SCM x);
-SCM_API SCM *scm_i_writable_velts (SCM x);
-SCM_API SCM scm_i_vector_ref (SCM x, size_t idx);
-SCM_API void scm_i_vector_set (SCM x, size_t idx, SCM val);
-SCM_API SCM scm_vector_equal_p (SCM x, SCM y);
+SCM_DEPRECATED int scm_i_vectorp (SCM x);
+SCM_DEPRECATED unsigned long scm_i_vector_length (SCM x);
+SCM_DEPRECATED const SCM *scm_i_velts (SCM x);
+SCM_DEPRECATED SCM *scm_i_writable_velts (SCM x);
+SCM_DEPRECATED SCM scm_i_vector_ref (SCM x, size_t idx);
+SCM_DEPRECATED void scm_i_vector_set (SCM x, size_t idx, SCM val);
+SCM_DEPRECATED SCM scm_vector_equal_p (SCM x, SCM y);
#define SCM_VECTORP(x) scm_i_vectorp(x)
#define SCM_VECTOR_LENGTH(x) scm_i_vector_length(x)
typedef scm_i_t_array scm_t_array;
-SCM_API int scm_i_arrayp (SCM a);
-SCM_API size_t scm_i_array_ndim (SCM a);
-SCM_API int scm_i_array_contp (SCM a);
-SCM_API scm_t_array *scm_i_array_mem (SCM a);
-SCM_API SCM scm_i_array_v (SCM a);
-SCM_API size_t scm_i_array_base (SCM a);
-SCM_API scm_t_array_dim *scm_i_array_dims (SCM a);
+SCM_DEPRECATED int scm_i_arrayp (SCM a);
+SCM_DEPRECATED size_t scm_i_array_ndim (SCM a);
+SCM_DEPRECATED int scm_i_array_contp (SCM a);
+SCM_DEPRECATED scm_t_array *scm_i_array_mem (SCM a);
+SCM_DEPRECATED SCM scm_i_array_v (SCM a);
+SCM_DEPRECATED size_t scm_i_array_base (SCM a);
+SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a);
#define SCM_ARRAYP(a) scm_i_arrayp(a)
#define SCM_ARRAY_NDIM(a) scm_i_array_ndim(a)
#define scm_cur_loadp scm_i_cur_loadp ()
#define scm_progargs scm_i_progargs ()
#define scm_dynwinds scm_i_deprecated_dynwinds ()
-#define scm_last_debug_frame scm_i_deprecated_last_debug_frame ()
#define scm_stack_base scm_i_stack_base ()
-SCM_API SCM scm_i_cur_inp (void);
-SCM_API SCM scm_i_cur_outp (void);
-SCM_API SCM scm_i_cur_errp (void);
-SCM_API SCM scm_i_cur_loadp (void);
-SCM_API SCM scm_i_progargs (void);
-SCM_API SCM scm_i_deprecated_dynwinds (void);
-SCM_API scm_t_debug_frame *scm_i_deprecated_last_debug_frame (void);
-SCM_API SCM_STACKITEM *scm_i_stack_base (void);
+SCM_DEPRECATED SCM scm_i_cur_inp (void);
+SCM_DEPRECATED SCM scm_i_cur_outp (void);
+SCM_DEPRECATED SCM scm_i_cur_errp (void);
+SCM_DEPRECATED SCM scm_i_cur_loadp (void);
+SCM_DEPRECATED SCM scm_i_progargs (void);
+SCM_DEPRECATED SCM scm_i_deprecated_dynwinds (void);
+SCM_DEPRECATED SCM_STACKITEM *scm_i_stack_base (void);
/* Deprecated because it evaluates its argument twice.
*/
#define SCM_FLUIDP(x) scm_i_fluidp (x)
-SCM_API int scm_i_fluidp (SCM x);
+SCM_DEPRECATED int scm_i_fluidp (SCM x);
+
+/* Deprecated in Guile 1.9.5 on 2009-11-15 because these are IPv4-only
+ functions which are deprecated upstream. */
+
+SCM_DEPRECATED SCM scm_inet_aton (SCM address);
+SCM_DEPRECATED SCM scm_inet_ntoa (SCM inetid);
/* In the old days, SCM_CRITICAL_SECTION_START stopped signal handlers
from running, since in those days the handler directly ran scheme
similar DEFER/ALLOW region.
*/
-SCM_API void scm_i_defer_ints_etc (void);
+SCM_DEPRECATED void scm_i_defer_ints_etc (void);
#define SCM_DEFER_INTS scm_i_defer_ints_etc ()
#define SCM_ALLOW_INTS scm_i_defer_ints_etc ()
#define SCM_REDEFER_INTS scm_i_defer_ints_etc ()
#define SCM_REALLOW_INTS scm_i_defer_ints_etc ()
+/* In the old days (pre-1.8), this macro was sometimes used as an lvalue as
+ in "scm_mask_ints = 1" to block async execution. It no longer works. */
+#define scm_mask_ints (scm_i_mask_ints ())
+
+SCM_DEPRECATED int scm_i_mask_ints (void);
+
/* Deprecated since they are unnecessary and had not been documented.
*/
-SCM_API SCM scm_guard (SCM guardian, SCM obj, int throw_p);
-SCM_API SCM scm_get_one_zombie (SCM guardian);
+SCM_DEPRECATED SCM scm_guard (SCM guardian, SCM obj, int throw_p);
+SCM_DEPRECATED SCM scm_get_one_zombie (SCM guardian);
/* Deprecated since guardians no longer have these special features.
*/
-SCM_API SCM scm_destroy_guardian_x (SCM guardian);
-SCM_API SCM scm_guardian_greedy_p (SCM guardian);
-SCM_API SCM scm_guardian_destroyed_p (SCM guardian);
+SCM_DEPRECATED SCM scm_destroy_guardian_x (SCM guardian);
+SCM_DEPRECATED SCM scm_guardian_greedy_p (SCM guardian);
+SCM_DEPRECATED SCM scm_guardian_destroyed_p (SCM guardian);
+
+\f
+/* GC-related things deprecated with the move to BDW-GC starting from 1.9.3
+ (2009-09-15). */
+
+SCM_DEPRECATED unsigned long scm_mallocated;
+SCM_DEPRECATED unsigned long scm_mtrigger;
+
+SCM_DEPRECATED size_t scm_max_segment_size;
+
+#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
+SCM_DEPRECATED SCM scm_map_free_list (void);
+#endif
+
+#if defined (GUILE_DEBUG_FREELIST)
+SCM_DEPRECATED SCM scm_gc_set_debug_check_freelist_x (SCM flag);
+#endif
+
+\f
+
+/* Deprecated 2009-11-27, scm_call_N is sufficient */
+SCM_DEPRECATED scm_t_trampoline_0 scm_trampoline_0 (SCM proc);
+SCM_DEPRECATED scm_t_trampoline_1 scm_trampoline_1 (SCM proc);
+SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
+
+\f
+
+/* Deprecated 2009-12-06, use the procedures instead */
+#define SCM_PROCEDURE_WITH_SETTER_P(obj) (scm_is_true (scm_procedure_with_setter_p (obj)))
+#define SCM_PROCEDURE(obj) SCM_STRUCT_PROCEDURE (obj, 0)
+#define SCM_SETTER(obj) SCM_STRUCT_SETTER (obj, 1)
+
+\f
void scm_i_init_deprecated (void);
/* dynl.c - dynamic linking
*
* Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
- * 2003, 2008 Free Software Foundation, Inc.
+ * 2003, 2008, 2009 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
#include <string.h>
#include "libguile/_scm.h"
+#include "libguile/libpath.h"
#include "libguile/dynl.h"
#include "libguile/smob.h"
#include "libguile/keywords.h"
static void
sysdep_dynl_init ()
{
+ char *env;
+
lt_dlinit ();
+
+ env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
+ if (env && strcmp (env, "") == 0)
+ /* special-case interpret system-ltdl-path=="" as meaning no system path,
+ which is the case during the build */
+ ;
+ else if (env)
+ /* FIXME: should this be a colon-separated path? Or is the only point to
+ allow the build system to turn off the installed extensions path? */
+ lt_dladdsearchdir (env);
+ else
+ {
+ lt_dladdsearchdir (SCM_LIB_DIR);
+ lt_dladdsearchdir (SCM_EXTENSIONS_DIR);
+ }
}
scm_t_bits scm_tc16_dynamic_obj;
#define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
-static SCM
-dynl_obj_mark (SCM ptr)
-{
- return DYNL_FILENAME (ptr);
-}
-
static int
dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
}
#undef FUNC_NAME
-static void
-free_string_pointers (void *data)
-{
- scm_i_free_string_pointers ((char **)data);
-}
-
SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
(SCM func, SCM dobj, SCM args),
"Call the C function indicated by @var{func} and @var{dobj},\n"
int result, argc;
char **argv;
- scm_dynwind_begin (0);
-
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
fptr = (int (*) (int, char **)) scm_to_ulong (func);
argv = scm_i_allocate_string_pointers (args);
- scm_dynwind_unwind_handler (free_string_pointers, argv,
- SCM_F_WIND_EXPLICITLY);
for (argc = 0; argv[argc]; argc++)
;
result = (*fptr) (argc, argv);
- scm_dynwind_end ();
return scm_from_int (result);
}
#undef FUNC_NAME
scm_init_dynamic_linking ()
{
scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
- scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark);
scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
sysdep_dynl_init ();
#include "libguile/dynl.x"
assert (0);
}
-static SCM
-winder_mark (SCM w)
-{
- if (WINDER_MARK_P (w))
- return SCM_PACK (WINDER_DATA (w));
- return SCM_BOOL_F;
-}
-
void
scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
scm_t_wind_flags flags)
tc16_frame = scm_make_smob_type ("frame", 0);
tc16_winder = scm_make_smob_type ("winder", 0);
- scm_set_smob_mark (tc16_winder, winder_mark);
#include "libguile/dynwind.x"
}
+++ /dev/null
-/* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public 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
- */
-
-\f
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/_scm.h"
-#include "libguile/alist.h"
-#include "libguile/eval.h"
-#include "libguile/hash.h"
-#include "libguile/list.h"
-#include "libguile/ports.h"
-#include "libguile/smob.h"
-#include "libguile/symbols.h"
-#include "libguile/vectors.h"
-#include "libguile/weaks.h"
-
-#include "libguile/environments.h"
-
-\f
-
-scm_t_bits scm_tc16_environment;
-scm_t_bits scm_tc16_observer;
-#define DEFAULT_OBARRAY_SIZE 31
-
-SCM scm_system_environment;
-
-\f
-
-/* error conditions */
-
-/*
- * Throw an error if symbol is not bound in environment func
- */
-void
-scm_error_environment_unbound (const char *func, SCM env, SCM symbol)
-{
- /* Dirk:FIXME:: Should throw an environment:unbound type error */
- char error[] = "Symbol `~A' not bound in environment `~A'.";
- SCM arguments = scm_cons2 (symbol, env, SCM_EOL);
- scm_misc_error (func, error, arguments);
-}
-
-
-/*
- * Throw an error if func tried to create (define) or remove
- * (undefine) a new binding for symbol in env
- */
-void
-scm_error_environment_immutable_binding (const char *func, SCM env, SCM symbol)
-{
- /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
- char error[] = "Immutable binding in environment ~A (symbol: `~A').";
- SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
- scm_misc_error (func, error, arguments);
-}
-
-
-/*
- * Throw an error if func tried to change an immutable location.
- */
-void
-scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol)
-{
- /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
- char error[] = "Immutable location in environment `~A' (symbol: `~A').";
- SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
- scm_misc_error (func, error, arguments);
-}
-
-\f
-
-/* generic environments */
-
-
-/* Create an environment for the given type. Dereferencing type twice must
- * deliver the initialized set of environment functions. Thus, type will
- * also determine the signature of the underlying environment implementation.
- * Dereferencing type once will typically deliver the data fields used by the
- * underlying environment implementation.
- */
-SCM
-scm_make_environment (void *type)
-{
- return scm_cell (scm_tc16_environment, (scm_t_bits) type);
-}
-
-
-SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_environment_p
-{
- return scm_from_bool (SCM_ENVIRONMENT_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0,
- (SCM env, SCM sym),
- "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
- "@code{#f} otherwise.")
-#define FUNC_NAME s_scm_environment_bound_p
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
-
- return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env, sym));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0,
- (SCM env, SCM sym),
- "Return the value of the location bound to @var{sym} in\n"
- "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
- "@code{environment:unbound} error.")
-#define FUNC_NAME s_scm_environment_ref
-{
- SCM val;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
-
- val = SCM_ENVIRONMENT_REF (env, sym);
-
- if (!SCM_UNBNDP (val))
- return val;
- else
- scm_error_environment_unbound (FUNC_NAME, env, sym);
-}
-#undef FUNC_NAME
-
-
-/* This C function is identical to environment-ref, except that if symbol is
- * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
- * an error.
- */
-SCM
-scm_c_environment_ref (SCM env, SCM sym)
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref");
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_ref");
- return SCM_ENVIRONMENT_REF (env, sym);
-}
-
-
-static SCM
-environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail)
-{
- return scm_call_3 (proc, symbol, value, tail);
-}
-
-
-SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0,
- (SCM env, SCM proc, SCM init),
- "Iterate over all the bindings in @var{env}, accumulating some\n"
- "value.\n"
- "For each binding in @var{env}, apply @var{proc} to the symbol\n"
- "bound, its value, and the result from the previous application\n"
- "of @var{proc}.\n"
- "Use @var{init} as @var{proc}'s third argument the first time\n"
- "@var{proc} is applied.\n"
- "If @var{env} contains no bindings, this function simply returns\n"
- "@var{init}.\n"
- "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
- "val2, and so on, then this procedure computes:\n"
- "@lisp\n"
- " (proc sym1 val1\n"
- " (proc sym2 val2\n"
- " ...\n"
- " (proc symn valn\n"
- " init)))\n"
- "@end lisp\n"
- "Each binding in @var{env} will be processed exactly once.\n"
- "@code{environment-fold} makes no guarantees about the order in\n"
- "which the bindings are processed.\n"
- "Here is a function which, given an environment, constructs an\n"
- "association list representing that environment's bindings,\n"
- "using environment-fold:\n"
- "@lisp\n"
- " (define (environment->alist env)\n"
- " (environment-fold env\n"
- " (lambda (sym val tail)\n"
- " (cons (cons sym val) tail))\n"
- " '()))\n"
- "@end lisp")
-#define FUNC_NAME s_scm_environment_fold
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
- proc, SCM_ARG2, FUNC_NAME);
-
- return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init);
-}
-#undef FUNC_NAME
-
-
-/* This is the C-level analog of environment-fold. For each binding in ENV,
- * make the call:
- * (*proc) (data, symbol, value, previous)
- * where previous is the value returned from the last call to *PROC, or INIT
- * for the first call. If ENV contains no bindings, return INIT.
- */
-SCM
-scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_fold");
-
- return SCM_ENVIRONMENT_FOLD (env, proc, data, init);
-}
-
-
-SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0,
- (SCM env, SCM sym, SCM val),
- "Bind @var{sym} to a new location containing @var{val} in\n"
- "@var{env}. If @var{sym} is already bound to another location\n"
- "in @var{env} and the binding is mutable, that binding is\n"
- "replaced. The new binding and location are both mutable. The\n"
- "return value is unspecified.\n"
- "If @var{sym} is already bound in @var{env}, and the binding is\n"
- "immutable, signal an @code{environment:immutable-binding} error.")
-#define FUNC_NAME s_scm_environment_define
-{
- SCM status;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
-
- status = SCM_ENVIRONMENT_DEFINE (env, sym, val);
-
- if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
- return SCM_UNSPECIFIED;
- else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
- scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
- else
- abort();
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0,
- (SCM env, SCM sym),
- "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
- "is unbound in @var{env}, do nothing. The return value is\n"
- "unspecified.\n"
- "If @var{sym} is already bound in @var{env}, and the binding is\n"
- "immutable, signal an @code{environment:immutable-binding} error.")
-#define FUNC_NAME s_scm_environment_undefine
-{
- SCM status;
-
- SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT(scm_is_symbol(sym), sym, SCM_ARG2, FUNC_NAME);
-
- status = SCM_ENVIRONMENT_UNDEFINE (env, sym);
-
- if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
- return SCM_UNSPECIFIED;
- else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
- scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
- else
- abort();
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0,
- (SCM env, SCM sym, SCM val),
- "If @var{env} binds @var{sym} to some location, change that\n"
- "location's value to @var{val}. The return value is\n"
- "unspecified.\n"
- "If @var{sym} is not bound in @var{env}, signal an\n"
- "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
- "to an immutable location, signal an\n"
- "@code{environment:immutable-location} error.")
-#define FUNC_NAME s_scm_environment_set_x
-{
- SCM status;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
-
- status = SCM_ENVIRONMENT_SET (env, sym, val);
-
- if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
- return SCM_UNSPECIFIED;
- else if (SCM_UNBNDP (status))
- scm_error_environment_unbound (FUNC_NAME, env, sym);
- else if (scm_is_eq (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
- scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
- else
- abort();
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0,
- (SCM env, SCM sym, SCM for_write),
- "Return the value cell which @var{env} binds to @var{sym}, or\n"
- "@code{#f} if the binding does not live in a value cell.\n"
- "The argument @var{for-write} indicates whether the caller\n"
- "intends to modify the variable's value by mutating the value\n"
- "cell. If the variable is immutable, then\n"
- "@code{environment-cell} signals an\n"
- "@code{environment:immutable-location} error.\n"
- "If @var{sym} is unbound in @var{env}, signal an\n"
- "@code{environment:unbound} error.\n"
- "If you use this function, you should consider using\n"
- "@code{environment-observe}, to be notified when @var{sym} gets\n"
- "re-bound to a new value cell, or becomes undefined.")
-#define FUNC_NAME s_scm_environment_cell
-{
- SCM location;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
- SCM_ASSERT (scm_is_bool (for_write), for_write, SCM_ARG3, FUNC_NAME);
-
- location = SCM_ENVIRONMENT_CELL (env, sym, scm_is_true (for_write));
- if (!SCM_IMP (location))
- return location;
- else if (SCM_UNBNDP (location))
- scm_error_environment_unbound (FUNC_NAME, env, sym);
- else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
- scm_error_environment_immutable_location (FUNC_NAME, env, sym);
- else /* no cell */
- return location;
-}
-#undef FUNC_NAME
-
-
-/* This C function is identical to environment-cell, with the following
- * exceptions: If symbol is unbound in env, it returns the value
- * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
- * immutable location but the cell is requested for write, the value
- * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
- */
-SCM
-scm_c_environment_cell(SCM env, SCM sym, int for_write)
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell");
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_cell");
-
- return SCM_ENVIRONMENT_CELL (env, sym, for_write);
-}
-
-
-static void
-environment_default_observer (SCM env, SCM proc)
-{
- scm_call_1 (proc, env);
-}
-
-
-SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0,
- (SCM env, SCM proc),
- "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
- "@var{env}.\n"
- "This function returns an object, token, which you can pass to\n"
- "@code{environment-unobserve} to remove @var{proc} from the set\n"
- "of procedures observing @var{env}. The type and value of\n"
- "token is unspecified.")
-#define FUNC_NAME s_scm_environment_observe
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 0);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0,
- (SCM env, SCM proc),
- "This function is the same as environment-observe, except that\n"
- "the reference @var{env} retains to @var{proc} is a weak\n"
- "reference. This means that, if there are no other live,\n"
- "non-weak references to @var{proc}, it will be\n"
- "garbage-collected, and dropped from @var{env}'s\n"
- "list of observing procedures.")
-#define FUNC_NAME s_scm_environment_observe_weak
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 1);
-}
-#undef FUNC_NAME
-
-
-/* This is the C-level analog of the Scheme functions environment-observe and
- * environment-observe-weak. Whenever env's bindings change, call the
- * function proc, passing it env and data. If weak_p is non-zero, env will
- * retain only a weak reference to data, and if data is garbage collected, the
- * entire observation will be dropped. This function returns a token, with
- * the same meaning as those returned by environment-observe and
- * environment-observe-weak.
- */
-SCM
-scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
-#define FUNC_NAME "scm_c_environment_observe"
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return SCM_ENVIRONMENT_OBSERVE (env, proc, data, weak_p);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0,
- (SCM token),
- "Cancel the observation request which returned the value\n"
- "@var{token}. The return value is unspecified.\n"
- "If a call @code{(environment-observe env proc)} returns\n"
- "@var{token}, then the call @code{(environment-unobserve token)}\n"
- "will cause @var{proc} to no longer be called when @var{env}'s\n"
- "bindings change.")
-#define FUNC_NAME s_scm_environment_unobserve
-{
- SCM env;
-
- SCM_ASSERT (SCM_OBSERVER_P (token), token, SCM_ARG1, FUNC_NAME);
-
- env = SCM_OBSERVER_ENVIRONMENT (token);
- SCM_ENVIRONMENT_UNOBSERVE (env, token);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-static SCM
-environment_mark (SCM env)
-{
- return (*(SCM_ENVIRONMENT_FUNCS (env)->mark)) (env);
-}
-
-
-static size_t
-environment_free (SCM env)
-{
- (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env);
- return 0;
-}
-
-
-static int
-environment_print (SCM env, SCM port, scm_print_state *pstate)
-{
- return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate);
-}
-
-\f
-
-/* observers */
-
-static SCM
-observer_mark (SCM observer)
-{
- scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer));
- scm_gc_mark (SCM_OBSERVER_DATA (observer));
- return SCM_BOOL_F;
-}
-
-
-static int
-observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<observer ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-\f
-
-/* obarrays
- *
- * Obarrays form the basic lookup tables used to implement most of guile's
- * built-in environment types. An obarray is implemented as a hash table with
- * symbols as keys. The content of the data depends on the environment type.
- */
-
-
-/*
- * Enter symbol into obarray. The symbol must not already exist in obarray.
- * The freshly generated (symbol . data) cell is returned.
- */
-static SCM
-obarray_enter (SCM obarray, SCM symbol, SCM data)
-{
- size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
- SCM entry = scm_cons (symbol, data);
- SCM slot = scm_cons (entry, SCM_HASHTABLE_BUCKET (obarray, hash));
- SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
- SCM_HASHTABLE_INCREMENT (obarray);
- if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
- scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_enter");
-
- return entry;
-}
-
-
-/*
- * Enter symbol into obarray. An existing entry for symbol is replaced. If
- * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
- */
-static SCM
-obarray_replace (SCM obarray, SCM symbol, SCM data)
-{
- size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
- SCM new_entry = scm_cons (symbol, data);
- SCM lsym;
- SCM slot;
-
- for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
- !scm_is_null (lsym);
- lsym = SCM_CDR (lsym))
- {
- SCM old_entry = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (old_entry), symbol))
- {
- SCM_SETCAR (lsym, new_entry);
- return old_entry;
- }
- }
-
- slot = scm_cons (new_entry, SCM_HASHTABLE_BUCKET (obarray, hash));
- SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
- SCM_HASHTABLE_INCREMENT (obarray);
- if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
- scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_replace");
-
- return SCM_BOOL_F;
-}
-
-
-/*
- * Look up symbol in obarray
- */
-static SCM
-obarray_retrieve (SCM obarray, SCM sym)
-{
- size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
- SCM lsym;
-
- for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
- !scm_is_null (lsym);
- lsym = SCM_CDR (lsym))
- {
- SCM entry = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (entry), sym))
- return entry;
- }
-
- return SCM_UNDEFINED;
-}
-
-
-/*
- * Remove entry from obarray. If the symbol was found and removed, the old
- * (symbol . data) cell is returned, #f otherwise.
- */
-static SCM
-obarray_remove (SCM obarray, SCM sym)
-{
- size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
- SCM table_entry = SCM_HASHTABLE_BUCKET (obarray, hash);
- SCM handle = scm_sloppy_assq (sym, table_entry);
-
- if (scm_is_pair (handle))
- {
- SCM new_table_entry = scm_delq1_x (handle, table_entry);
- SCM_SET_HASHTABLE_BUCKET (obarray, hash, new_table_entry);
- SCM_HASHTABLE_DECREMENT (obarray);
- }
-
- return handle;
-}
-
-
-static void
-obarray_remove_all (SCM obarray)
-{
- size_t size = SCM_HASHTABLE_N_BUCKETS (obarray);
- size_t i;
-
- for (i = 0; i < size; i++)
- {
- SCM_SET_HASHTABLE_BUCKET (obarray, i, SCM_EOL);
- }
- SCM_SET_HASHTABLE_N_ITEMS (obarray, 0);
-}
-
-\f
-
-/* core environments base
- *
- * This struct and the corresponding functions form a base class for guile's
- * built-in environment types.
- */
-
-
-struct core_environments_base {
- struct scm_environment_funcs *funcs;
-
- SCM observers;
- SCM weak_observers;
-};
-
-
-#define CORE_ENVIRONMENTS_BASE(env) \
- ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
-#define CORE_ENVIRONMENT_OBSERVERS(env) \
- (CORE_ENVIRONMENTS_BASE (env)->observers)
-#define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
- (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
-#define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
- (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
-#define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
- (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
-#define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
- (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
-
-\f
-
-static SCM
-core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
-{
- SCM observer = scm_double_cell (scm_tc16_observer,
- SCM_UNPACK (env),
- SCM_UNPACK (data),
- (scm_t_bits) proc);
-
- if (!weak_p)
- {
- SCM observers = CORE_ENVIRONMENT_OBSERVERS (env);
- SCM new_observers = scm_cons (observer, observers);
- SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, new_observers);
- }
- else
- {
- SCM observers = CORE_ENVIRONMENT_WEAK_OBSERVERS (env);
- SCM new_observers = scm_acons (SCM_BOOL_F, observer, observers);
- SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, new_observers);
- }
-
- return observer;
-}
-
-
-static void
-core_environments_unobserve (SCM env, SCM observer)
-{
- unsigned int handling_weaks;
- for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
- {
- SCM l = handling_weaks
- ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
- : CORE_ENVIRONMENT_OBSERVERS (env);
-
- if (!scm_is_null (l))
- {
- SCM rest = SCM_CDR (l);
- SCM first = handling_weaks
- ? SCM_CDAR (l)
- : SCM_CAR (l);
-
- if (scm_is_eq (first, observer))
- {
- /* Remove the first observer */
- if (handling_weaks)
- SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest);
- else
- SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
- return;
- }
-
- do {
- SCM rest = SCM_CDR (l);
-
- if (!scm_is_null (rest))
- {
- SCM next = handling_weaks
- ? SCM_CDAR (l)
- : SCM_CAR (l);
-
- if (scm_is_eq (next, observer))
- {
- SCM_SETCDR (l, SCM_CDR (rest));
- return;
- }
- }
-
- l = rest;
- } while (!scm_is_null (l));
- }
- }
-
- /* Dirk:FIXME:: What to do now, since the observer is not found? */
-}
-
-
-static SCM
-core_environments_mark (SCM env)
-{
- scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env));
- return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env);
-}
-
-
-static void
-core_environments_finalize (SCM env SCM_UNUSED)
-{
-}
-
-
-static void
-core_environments_preinit (struct core_environments_base *body)
-{
- body->funcs = NULL;
- body->observers = SCM_BOOL_F;
- body->weak_observers = SCM_BOOL_F;
-}
-
-
-static void
-core_environments_init (struct core_environments_base *body,
- struct scm_environment_funcs *funcs)
-{
- body->funcs = funcs;
- body->observers = SCM_EOL;
- body->weak_observers = scm_make_weak_value_alist_vector (scm_from_int (1));
-}
-
-
-/* Tell all observers to clear their caches.
- *
- * Environments have to be informed about changes in the following cases:
- * - The observed env has a new binding. This must be always reported.
- * - The observed env has dropped a binding. This must be always reported.
- * - A binding in the observed environment has changed. This must only be
- * reported, if there is a chance that the binding is being cached outside.
- * However, this potential optimization is not performed currently.
- *
- * Errors that occur while the observers are called are accumulated and
- * signalled as one single error message to the caller.
- */
-
-struct update_data
-{
- SCM observer;
- SCM environment;
-};
-
-
-static SCM
-update_catch_body (void *ptr)
-{
- struct update_data *data = (struct update_data *) ptr;
- SCM observer = data->observer;
-
- (*SCM_OBSERVER_PROC (observer))
- (data->environment, SCM_OBSERVER_DATA (observer));
-
- return SCM_UNDEFINED;
-}
-
-
-static SCM
-update_catch_handler (void *ptr, SCM tag, SCM args)
-{
- struct update_data *data = (struct update_data *) ptr;
- SCM observer = data->observer;
- SCM message =
- scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
-
- return scm_cons (message, scm_list_3 (observer, tag, args));
-}
-
-
-static void
-core_environments_broadcast (SCM env)
-#define FUNC_NAME "core_environments_broadcast"
-{
- unsigned int handling_weaks;
- SCM errors = SCM_EOL;
-
- for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
- {
- SCM observers = handling_weaks
- ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
- : CORE_ENVIRONMENT_OBSERVERS (env);
-
- for (; !scm_is_null (observers); observers = SCM_CDR (observers))
- {
- struct update_data data;
- SCM observer = handling_weaks
- ? SCM_CDAR (observers)
- : SCM_CAR (observers);
- SCM error;
-
- data.observer = observer;
- data.environment = env;
-
- error = scm_internal_catch (SCM_BOOL_T,
- update_catch_body, &data,
- update_catch_handler, &data);
-
- if (!SCM_UNBNDP (error))
- errors = scm_cons (error, errors);
- }
- }
-
- if (!scm_is_null (errors))
- {
- /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
- * parameter correctly it should not be necessary any more to also pass
- * namestr in order to get the desired information from the error
- * message.
- */
- SCM ordered_errors = scm_reverse (errors);
- scm_misc_error
- (FUNC_NAME,
- "Observers of `~A' have signalled the following errors: ~S",
- scm_cons2 (env, ordered_errors, SCM_EOL));
- }
-}
-#undef FUNC_NAME
-
-\f
-
-/* leaf environments
- *
- * A leaf environment is simply a mutable set of definitions. A leaf
- * environment supports no operations beyond the common set.
- *
- * Implementation: The obarray of the leaf environment holds (symbol . value)
- * pairs. No further information is necessary, since all bindings and
- * locations in a leaf environment are mutable.
- */
-
-
-struct leaf_environment {
- struct core_environments_base base;
-
- SCM obarray;
-};
-
-
-#define LEAF_ENVIRONMENT(env) \
- ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
-
-\f
-
-static SCM
-leaf_environment_ref (SCM env, SCM sym)
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
- SCM binding = obarray_retrieve (obarray, sym);
- return SCM_UNBNDP (binding) ? binding : SCM_CDR (binding);
-}
-
-
-static SCM
-leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- size_t i;
- SCM result = init;
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
-
- for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (obarray); i++)
- {
- SCM l;
- for (l = SCM_HASHTABLE_BUCKET (obarray, i);
- !scm_is_null (l);
- l = SCM_CDR (l))
- {
- SCM binding = SCM_CAR (l);
- SCM symbol = SCM_CAR (binding);
- SCM value = SCM_CDR (binding);
- result = (*proc) (data, symbol, value, result);
- }
- }
- return result;
-}
-
-
-static SCM
-leaf_environment_define (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "leaf_environment_define"
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
-
- obarray_replace (obarray, sym, val);
- core_environments_broadcast (env);
-
- return SCM_ENVIRONMENT_SUCCESS;
-}
-#undef FUNC_NAME
-
-
-static SCM
-leaf_environment_undefine (SCM env, SCM sym)
-#define FUNC_NAME "leaf_environment_undefine"
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
- SCM removed = obarray_remove (obarray, sym);
-
- if (scm_is_true (removed))
- core_environments_broadcast (env);
-
- return SCM_ENVIRONMENT_SUCCESS;
-}
-#undef FUNC_NAME
-
-
-static SCM
-leaf_environment_set_x (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "leaf_environment_set_x"
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
- SCM binding = obarray_retrieve (obarray, sym);
-
- if (!SCM_UNBNDP (binding))
- {
- SCM_SETCDR (binding, val);
- return SCM_ENVIRONMENT_SUCCESS;
- }
- else
- {
- return SCM_UNDEFINED;
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-leaf_environment_cell (SCM env, SCM sym, int for_write SCM_UNUSED)
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
- SCM binding = obarray_retrieve (obarray, sym);
- return binding;
-}
-
-
-static SCM
-leaf_environment_mark (SCM env)
-{
- scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray);
- return core_environments_mark (env);
-}
-
-
-static void
-leaf_environment_free (SCM env)
-{
- core_environments_finalize (env);
- scm_gc_free (LEAF_ENVIRONMENT (env), sizeof (struct leaf_environment),
- "leaf environment");
-}
-
-
-static int
-leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<leaf environment ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-static struct scm_environment_funcs leaf_environment_funcs = {
- leaf_environment_ref,
- leaf_environment_fold,
- leaf_environment_define,
- leaf_environment_undefine,
- leaf_environment_set_x,
- leaf_environment_cell,
- core_environments_observe,
- core_environments_unobserve,
- leaf_environment_mark,
- leaf_environment_free,
- leaf_environment_print
-};
-
-
-void *scm_type_leaf_environment = &leaf_environment_funcs;
-
-
-SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0,
- (),
- "Create a new leaf environment, containing no bindings.\n"
- "All bindings and locations created in the new environment\n"
- "will be mutable.")
-#define FUNC_NAME s_scm_make_leaf_environment
-{
- size_t size = sizeof (struct leaf_environment);
- struct leaf_environment *body = scm_gc_malloc (size, "leaf environment");
- SCM env;
-
- core_environments_preinit (&body->base);
- body->obarray = SCM_BOOL_F;
-
- env = scm_make_environment (body);
-
- core_environments_init (&body->base, &leaf_environment_funcs);
- body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
-
- return env;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0,
- (SCM object),
- "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_leaf_environment_p
-{
- return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object));
-}
-#undef FUNC_NAME
-
-\f
-
-/* eval environments
- *
- * A module's source code refers to definitions imported from other modules,
- * and definitions made within itself. An eval environment combines two
- * environments -- a local environment and an imported environment -- to
- * produce a new environment in which both sorts of references can be
- * resolved.
- *
- * Implementation: The obarray of the eval environment is used to cache
- * entries from the local and imported environments such that in most of the
- * cases only a single lookup is necessary. Since for neither the local nor
- * the imported environment it is known, what kind of environment they form,
- * the most general case is assumed. Therefore, entries in the obarray take
- * one of the following forms:
- *
- * 1) (<symbol> location mutability . source-env), where mutability indicates
- * one of the following states: IMMUTABLE if the location is known to be
- * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
- * the location has only been requested for non modifying accesses.
- *
- * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
- * if the source-env can't provide a cell for the binding. Thus, for every
- * access, the source-env has to be contacted directly.
- */
-
-
-struct eval_environment {
- struct core_environments_base base;
-
- SCM obarray;
-
- SCM imported;
- SCM imported_observer;
- SCM local;
- SCM local_observer;
-};
-
-
-#define EVAL_ENVIRONMENT(env) \
- ((struct eval_environment *) SCM_CELL_WORD_1 (env))
-
-#define IMMUTABLE SCM_I_MAKINUM (0)
-#define MUTABLE SCM_I_MAKINUM (1)
-#define UNKNOWN SCM_I_MAKINUM (2)
-
-#define CACHED_LOCATION(x) SCM_CAR (x)
-#define CACHED_MUTABILITY(x) SCM_CADR (x)
-#define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
-#define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
-
-\f
-
-/* eval_environment_lookup will report one of the following distinct results:
- * a) (<object> . value) if a cell could be obtained.
- * b) <environment> if the environment has to be contacted directly.
- * c) IMMUTABLE if an immutable cell was requested for write.
- * d) SCM_UNDEFINED if there is no binding for the symbol.
- */
-static SCM
-eval_environment_lookup (SCM env, SCM sym, int for_write)
-{
- SCM obarray = EVAL_ENVIRONMENT (env)->obarray;
- SCM binding = obarray_retrieve (obarray, sym);
-
- if (!SCM_UNBNDP (binding))
- {
- /* The obarray holds an entry for the symbol. */
-
- SCM entry = SCM_CDR (binding);
-
- if (scm_is_pair (entry))
- {
- /* The entry in the obarray is a cached location. */
-
- SCM location = CACHED_LOCATION (entry);
- SCM mutability;
-
- if (!for_write)
- return location;
-
- mutability = CACHED_MUTABILITY (entry);
- if (scm_is_eq (mutability, MUTABLE))
- return location;
-
- if (scm_is_eq (mutability, UNKNOWN))
- {
- SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry);
- SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1);
-
- if (scm_is_pair (location))
- {
- SET_CACHED_MUTABILITY (entry, MUTABLE);
- return location;
- }
- else /* IMMUTABLE */
- {
- SET_CACHED_MUTABILITY (entry, IMMUTABLE);
- return IMMUTABLE;
- }
- }
-
- return IMMUTABLE;
- }
- else
- {
- /* The obarray entry is an environment */
-
- return entry;
- }
- }
- else
- {
- /* There is no entry for the symbol in the obarray. This can either
- * mean that there has not been a request for the symbol yet, or that
- * the symbol is really undefined. We are looking for the symbol in
- * both the local and the imported environment. If we find a binding, a
- * cached entry is created.
- */
-
- struct eval_environment *body = EVAL_ENVIRONMENT (env);
- unsigned int handling_import;
-
- for (handling_import = 0; handling_import <= 1; ++handling_import)
- {
- SCM source_env = handling_import ? body->imported : body->local;
- SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, for_write);
-
- if (!SCM_UNBNDP (location))
- {
- if (scm_is_pair (location))
- {
- SCM mutability = for_write ? MUTABLE : UNKNOWN;
- SCM entry = scm_cons2 (location, mutability, source_env);
- obarray_enter (obarray, sym, entry);
- return location;
- }
- else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_NO_CELL))
- {
- obarray_enter (obarray, sym, source_env);
- return source_env;
- }
- else
- {
- return IMMUTABLE;
- }
- }
- }
-
- return SCM_UNDEFINED;
- }
-}
-
-
-static SCM
-eval_environment_ref (SCM env, SCM sym)
-#define FUNC_NAME "eval_environment_ref"
-{
- SCM location = eval_environment_lookup (env, sym, 0);
-
- if (scm_is_pair (location))
- return SCM_CDR (location);
- else if (!SCM_UNBNDP (location))
- return SCM_ENVIRONMENT_REF (location, sym);
- else
- return SCM_UNDEFINED;
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
-{
- SCM local = SCM_CAR (extended_data);
-
- if (!SCM_ENVIRONMENT_BOUND_P (local, symbol))
- {
- SCM proc_as_nr = SCM_CADR (extended_data);
- unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
- scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
- SCM data = SCM_CDDR (extended_data);
-
- return (*proc) (data, symbol, value, tail);
- }
- else
- {
- return tail;
- }
-}
-
-
-static SCM
-eval_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- SCM local = EVAL_ENVIRONMENT (env)->local;
- SCM imported = EVAL_ENVIRONMENT (env)->imported;
- SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
- SCM extended_data = scm_cons2 (local, proc_as_nr, data);
- SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init);
-
- return scm_c_environment_fold (local, proc, data, tmp_result);
-}
-
-
-static SCM
-eval_environment_define (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "eval_environment_define"
-{
- SCM local = EVAL_ENVIRONMENT (env)->local;
- return SCM_ENVIRONMENT_DEFINE (local, sym, val);
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_undefine (SCM env, SCM sym)
-#define FUNC_NAME "eval_environment_undefine"
-{
- SCM local = EVAL_ENVIRONMENT (env)->local;
- return SCM_ENVIRONMENT_UNDEFINE (local, sym);
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_set_x (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "eval_environment_set_x"
-{
- SCM location = eval_environment_lookup (env, sym, 1);
-
- if (scm_is_pair (location))
- {
- SCM_SETCDR (location, val);
- return SCM_ENVIRONMENT_SUCCESS;
- }
- else if (SCM_ENVIRONMENT_P (location))
- {
- return SCM_ENVIRONMENT_SET (location, sym, val);
- }
- else if (scm_is_eq (location, IMMUTABLE))
- {
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- }
- else
- {
- return SCM_UNDEFINED;
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_cell (SCM env, SCM sym, int for_write)
-#define FUNC_NAME "eval_environment_cell"
-{
- SCM location = eval_environment_lookup (env, sym, for_write);
-
- if (scm_is_pair (location))
- return location;
- else if (SCM_ENVIRONMENT_P (location))
- return SCM_ENVIRONMENT_LOCATION_NO_CELL;
- else if (scm_is_eq (location, IMMUTABLE))
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- else
- return SCM_UNDEFINED;
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_mark (SCM env)
-{
- struct eval_environment *body = EVAL_ENVIRONMENT (env);
-
- scm_gc_mark (body->obarray);
- scm_gc_mark (body->imported);
- scm_gc_mark (body->imported_observer);
- scm_gc_mark (body->local);
- scm_gc_mark (body->local_observer);
-
- return core_environments_mark (env);
-}
-
-
-static void
-eval_environment_free (SCM env)
-{
- core_environments_finalize (env);
- scm_gc_free (EVAL_ENVIRONMENT (env), sizeof (struct eval_environment),
- "eval environment");
-}
-
-
-static int
-eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<eval environment ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-static struct scm_environment_funcs eval_environment_funcs = {
- eval_environment_ref,
- eval_environment_fold,
- eval_environment_define,
- eval_environment_undefine,
- eval_environment_set_x,
- eval_environment_cell,
- core_environments_observe,
- core_environments_unobserve,
- eval_environment_mark,
- eval_environment_free,
- eval_environment_print
-};
-
-
-void *scm_type_eval_environment = &eval_environment_funcs;
-
-
-static void
-eval_environment_observer (SCM caller SCM_UNUSED, SCM eval_env)
-{
- SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray;
-
- obarray_remove_all (obarray);
- core_environments_broadcast (eval_env);
-}
-
-
-SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0,
- (SCM local, SCM imported),
- "Return a new environment object eval whose bindings are the\n"
- "union of the bindings in the environments @var{local} and\n"
- "@var{imported}, with bindings from @var{local} taking\n"
- "precedence. Definitions made in eval are placed in @var{local}.\n"
- "Applying @code{environment-define} or\n"
- "@code{environment-undefine} to eval has the same effect as\n"
- "applying the procedure to @var{local}.\n"
- "Note that eval incorporates @var{local} and @var{imported} by\n"
- "reference:\n"
- "If, after creating eval, the program changes the bindings of\n"
- "@var{local} or @var{imported}, those changes will be visible\n"
- "in eval.\n"
- "Since most Scheme evaluation takes place in eval environments,\n"
- "they transparently cache the bindings received from @var{local}\n"
- "and @var{imported}. Thus, the first time the program looks up\n"
- "a symbol in eval, eval may make calls to @var{local} or\n"
- "@var{imported} to find their bindings, but subsequent\n"
- "references to that symbol will be as fast as references to\n"
- "bindings in finite environments.\n"
- "In typical use, @var{local} will be a finite environment, and\n"
- "@var{imported} will be an import environment")
-#define FUNC_NAME s_scm_make_eval_environment
-{
- SCM env;
- struct eval_environment *body;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
-
- body = scm_gc_malloc (sizeof (struct eval_environment), "eval environment");
-
- core_environments_preinit (&body->base);
- body->obarray = SCM_BOOL_F;
- body->imported = SCM_BOOL_F;
- body->imported_observer = SCM_BOOL_F;
- body->local = SCM_BOOL_F;
- body->local_observer = SCM_BOOL_F;
-
- env = scm_make_environment (body);
-
- core_environments_init (&body->base, &eval_environment_funcs);
- body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
- body->imported = imported;
- body->imported_observer
- = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
- body->local = local;
- body->local_observer
- = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
-
- return env;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0,
- (SCM object),
- "Return @code{#t} if object is an eval environment, or @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_eval_environment_p
-{
- return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0,
- (SCM env),
- "Return the local environment of eval environment @var{env}.")
-#define FUNC_NAME s_scm_eval_environment_local
-{
- SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return EVAL_ENVIRONMENT (env)->local;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0,
- (SCM env, SCM local),
- "Change @var{env}'s local environment to @var{local}.")
-#define FUNC_NAME s_scm_eval_environment_set_local_x
-{
- struct eval_environment *body;
-
- SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG2, FUNC_NAME);
-
- body = EVAL_ENVIRONMENT (env);
-
- obarray_remove_all (body->obarray);
- SCM_ENVIRONMENT_UNOBSERVE (body->local, body->local_observer);
-
- body->local = local;
- body->local_observer
- = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
-
- core_environments_broadcast (env);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0,
- (SCM env),
- "Return the imported environment of eval environment @var{env}.")
-#define FUNC_NAME s_scm_eval_environment_imported
-{
- SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return EVAL_ENVIRONMENT (env)->imported;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0,
- (SCM env, SCM imported),
- "Change @var{env}'s imported environment to @var{imported}.")
-#define FUNC_NAME s_scm_eval_environment_set_imported_x
-{
- struct eval_environment *body;
-
- SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
-
- body = EVAL_ENVIRONMENT (env);
-
- obarray_remove_all (body->obarray);
- SCM_ENVIRONMENT_UNOBSERVE (body->imported, body->imported_observer);
-
- body->imported = imported;
- body->imported_observer
- = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
-
- core_environments_broadcast (env);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-\f
-
-/* import environments
- *
- * An import environment combines the bindings of a set of argument
- * environments, and checks for naming clashes.
- *
- * Implementation: The import environment does no caching at all. For every
- * access, the list of imported environments is scanned.
- */
-
-
-struct import_environment {
- struct core_environments_base base;
-
- SCM imports;
- SCM import_observers;
-
- SCM conflict_proc;
-};
-
-
-#define IMPORT_ENVIRONMENT(env) \
- ((struct import_environment *) SCM_CELL_WORD_1 (env))
-
-\f
-
-/* Lookup will report one of the following distinct results:
- * a) <environment> if only environment binds the symbol.
- * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
- * c) SCM_UNDEFINED if there is no binding for the symbol.
- */
-static SCM
-import_environment_lookup (SCM env, SCM sym)
-{
- SCM imports = IMPORT_ENVIRONMENT (env)->imports;
- SCM result = SCM_UNDEFINED;
- SCM l;
-
- for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM imported = SCM_CAR (l);
-
- if (SCM_ENVIRONMENT_BOUND_P (imported, sym))
- {
- if (SCM_UNBNDP (result))
- result = imported;
- else if (scm_is_pair (result))
- result = scm_cons (imported, result);
- else
- result = scm_cons2 (imported, result, SCM_EOL);
- }
- }
-
- if (scm_is_pair (result))
- return scm_reverse (result);
- else
- return result;
-}
-
-
-static SCM
-import_environment_conflict (SCM env, SCM sym, SCM imports)
-{
- SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc;
- SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL));
-
- return scm_apply_0 (conflict_proc, args);
-}
-
-
-static SCM
-import_environment_ref (SCM env, SCM sym)
-#define FUNC_NAME "import_environment_ref"
-{
- SCM owner = import_environment_lookup (env, sym);
-
- if (SCM_UNBNDP (owner))
- {
- return SCM_UNDEFINED;
- }
- else if (scm_is_pair (owner))
- {
- SCM resolve = import_environment_conflict (env, sym, owner);
-
- if (SCM_ENVIRONMENT_P (resolve))
- return SCM_ENVIRONMENT_REF (resolve, sym);
- else
- return SCM_UNSPECIFIED;
- }
- else
- {
- return SCM_ENVIRONMENT_REF (owner, sym);
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
-#define FUNC_NAME "import_environment_fold"
-{
- SCM import_env = SCM_CAR (extended_data);
- SCM imported_env = SCM_CADR (extended_data);
- SCM owner = import_environment_lookup (import_env, symbol);
- SCM proc_as_nr = SCM_CADDR (extended_data);
- unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
- scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
- SCM data = SCM_CDDDR (extended_data);
-
- if (scm_is_pair (owner) && scm_is_eq (SCM_CAR (owner), imported_env))
- owner = import_environment_conflict (import_env, symbol, owner);
-
- if (SCM_ENVIRONMENT_P (owner))
- return (*proc) (data, symbol, value, tail);
- else /* unresolved conflict */
- return (*proc) (data, symbol, SCM_UNSPECIFIED, tail);
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
- SCM result = init;
- SCM l;
-
- for (l = IMPORT_ENVIRONMENT (env)->imports; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM imported_env = SCM_CAR (l);
- SCM extended_data = scm_cons (env, scm_cons2 (imported_env, proc_as_nr, data));
-
- result = scm_c_environment_fold (imported_env, import_environment_folder, extended_data, result);
- }
-
- return result;
-}
-
-
-static SCM
-import_environment_define (SCM env SCM_UNUSED,
- SCM sym SCM_UNUSED,
- SCM val SCM_UNUSED)
-#define FUNC_NAME "import_environment_define"
-{
- return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_undefine (SCM env SCM_UNUSED,
- SCM sym SCM_UNUSED)
-#define FUNC_NAME "import_environment_undefine"
-{
- return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_set_x (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "import_environment_set_x"
-{
- SCM owner = import_environment_lookup (env, sym);
-
- if (SCM_UNBNDP (owner))
- {
- return SCM_UNDEFINED;
- }
- else if (scm_is_pair (owner))
- {
- SCM resolve = import_environment_conflict (env, sym, owner);
-
- if (SCM_ENVIRONMENT_P (resolve))
- return SCM_ENVIRONMENT_SET (resolve, sym, val);
- else
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- }
- else
- {
- return SCM_ENVIRONMENT_SET (owner, sym, val);
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_cell (SCM env, SCM sym, int for_write)
-#define FUNC_NAME "import_environment_cell"
-{
- SCM owner = import_environment_lookup (env, sym);
-
- if (SCM_UNBNDP (owner))
- {
- return SCM_UNDEFINED;
- }
- else if (scm_is_pair (owner))
- {
- SCM resolve = import_environment_conflict (env, sym, owner);
-
- if (SCM_ENVIRONMENT_P (resolve))
- return SCM_ENVIRONMENT_CELL (resolve, sym, for_write);
- else
- return SCM_ENVIRONMENT_LOCATION_NO_CELL;
- }
- else
- {
- return SCM_ENVIRONMENT_CELL (owner, sym, for_write);
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_mark (SCM env)
-{
- scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports);
- scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers);
- scm_gc_mark (IMPORT_ENVIRONMENT (env)->conflict_proc);
- return core_environments_mark (env);
-}
-
-
-static void
-import_environment_free (SCM env)
-{
- core_environments_finalize (env);
- scm_gc_free (IMPORT_ENVIRONMENT (env), sizeof (struct import_environment),
- "import environment");
-}
-
-
-static int
-import_environment_print (SCM type, SCM port,
- scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<import environment ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-static struct scm_environment_funcs import_environment_funcs = {
- import_environment_ref,
- import_environment_fold,
- import_environment_define,
- import_environment_undefine,
- import_environment_set_x,
- import_environment_cell,
- core_environments_observe,
- core_environments_unobserve,
- import_environment_mark,
- import_environment_free,
- import_environment_print
-};
-
-
-void *scm_type_import_environment = &import_environment_funcs;
-
-
-static void
-import_environment_observer (SCM caller SCM_UNUSED, SCM import_env)
-{
- core_environments_broadcast (import_env);
-}
-
-
-SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0,
- (SCM imports, SCM conflict_proc),
- "Return a new environment @var{imp} whose bindings are the union\n"
- "of the bindings from the environments in @var{imports};\n"
- "@var{imports} must be a list of environments. That is,\n"
- "@var{imp} binds a symbol to a location when some element of\n"
- "@var{imports} does.\n"
- "If two different elements of @var{imports} have a binding for\n"
- "the same symbol, the @var{conflict-proc} is called with the\n"
- "following parameters: the import environment, the symbol and\n"
- "the list of the imported environments that bind the symbol.\n"
- "If the @var{conflict-proc} returns an environment @var{env},\n"
- "the conflict is considered as resolved and the binding from\n"
- "@var{env} is used. If the @var{conflict-proc} returns some\n"
- "non-environment object, the conflict is considered unresolved\n"
- "and the symbol is treated as unspecified in the import\n"
- "environment.\n"
- "The checking for conflicts may be performed lazily, i. e. at\n"
- "the moment when a value or binding for a certain symbol is\n"
- "requested instead of the moment when the environment is\n"
- "created or the bindings of the imports change.\n"
- "All bindings in @var{imp} are immutable. If you apply\n"
- "@code{environment-define} or @code{environment-undefine} to\n"
- "@var{imp}, Guile will signal an\n"
- " @code{environment:immutable-binding} error. However,\n"
- "notice that the set of bindings in @var{imp} may still change,\n"
- "if one of its imported environments changes.")
-#define FUNC_NAME s_scm_make_import_environment
-{
- size_t size = sizeof (struct import_environment);
- struct import_environment *body = scm_gc_malloc (size, "import environment");
- SCM env;
-
- core_environments_preinit (&body->base);
- body->imports = SCM_BOOL_F;
- body->import_observers = SCM_BOOL_F;
- body->conflict_proc = SCM_BOOL_F;
-
- env = scm_make_environment (body);
-
- core_environments_init (&body->base, &import_environment_funcs);
- body->imports = SCM_EOL;
- body->import_observers = SCM_EOL;
- body->conflict_proc = conflict_proc;
-
- scm_import_environment_set_imports_x (env, imports);
-
- return env;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0,
- (SCM object),
- "Return @code{#t} if object is an import environment, or\n"
- "@code{#f} otherwise.")
-#define FUNC_NAME s_scm_import_environment_p
-{
- return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0,
- (SCM env),
- "Return the list of environments imported by the import\n"
- "environment @var{env}.")
-#define FUNC_NAME s_scm_import_environment_imports
-{
- SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return IMPORT_ENVIRONMENT (env)->imports;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0,
- (SCM env, SCM imports),
- "Change @var{env}'s list of imported environments to\n"
- "@var{imports}, and check for conflicts.")
-#define FUNC_NAME s_scm_import_environment_set_imports_x
-{
- struct import_environment *body = IMPORT_ENVIRONMENT (env);
- SCM import_observers = SCM_EOL;
- SCM l;
-
- SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- for (l = imports; scm_is_pair (l); l = SCM_CDR (l))
- {
- SCM obj = SCM_CAR (l);
- SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG2, FUNC_NAME);
- }
- SCM_ASSERT (scm_is_null (l), imports, SCM_ARG2, FUNC_NAME);
-
- for (l = body->import_observers; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM obs = SCM_CAR (l);
- SCM_ENVIRONMENT_UNOBSERVE (env, obs);
- }
-
- for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM imp = SCM_CAR (l);
- SCM obs = SCM_ENVIRONMENT_OBSERVE (imp, import_environment_observer, env, 1);
- import_observers = scm_cons (obs, import_observers);
- }
-
- body->imports = imports;
- body->import_observers = import_observers;
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-\f
-
-/* export environments
- *
- * An export environment restricts an environment to a specified set of
- * bindings.
- *
- * Implementation: The export environment does no caching at all. For every
- * access, the signature is scanned. The signature that is stored internally
- * is an alist of pairs (symbol . (mutability)).
- */
-
-
-struct export_environment {
- struct core_environments_base base;
-
- SCM private;
- SCM private_observer;
-
- SCM signature;
-};
-
-
-#define EXPORT_ENVIRONMENT(env) \
- ((struct export_environment *) SCM_CELL_WORD_1 (env))
-
-
-SCM_SYMBOL (symbol_immutable_location, "immutable-location");
-SCM_SYMBOL (symbol_mutable_location, "mutable-location");
-
-\f
-
-static SCM
-export_environment_ref (SCM env, SCM sym)
-#define FUNC_NAME "export_environment_ref"
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
- SCM entry = scm_assq (sym, body->signature);
-
- if (scm_is_false (entry))
- return SCM_UNDEFINED;
- else
- return SCM_ENVIRONMENT_REF (body->private, sym);
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
- SCM result = init;
- SCM l;
-
- for (l = body->signature; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM symbol = SCM_CAR (l);
- SCM value = SCM_ENVIRONMENT_REF (body->private, symbol);
- if (!SCM_UNBNDP (value))
- result = (*proc) (data, symbol, value, result);
- }
- return result;
-}
-
-
-static SCM
-export_environment_define (SCM env SCM_UNUSED,
- SCM sym SCM_UNUSED,
- SCM val SCM_UNUSED)
-#define FUNC_NAME "export_environment_define"
-{
- return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_undefine (SCM env SCM_UNUSED, SCM sym SCM_UNUSED)
-#define FUNC_NAME "export_environment_undefine"
-{
- return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_set_x (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "export_environment_set_x"
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
- SCM entry = scm_assq (sym, body->signature);
-
- if (scm_is_false (entry))
- {
- return SCM_UNDEFINED;
- }
- else
- {
- if (scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
- return SCM_ENVIRONMENT_SET (body->private, sym, val);
- else
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_cell (SCM env, SCM sym, int for_write)
-#define FUNC_NAME "export_environment_cell"
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
- SCM entry = scm_assq (sym, body->signature);
-
- if (scm_is_false (entry))
- {
- return SCM_UNDEFINED;
- }
- else
- {
- if (!for_write || scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
- return SCM_ENVIRONMENT_CELL (body->private, sym, for_write);
- else
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_mark (SCM env)
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
-
- scm_gc_mark (body->private);
- scm_gc_mark (body->private_observer);
- scm_gc_mark (body->signature);
-
- return core_environments_mark (env);
-}
-
-
-static void
-export_environment_free (SCM env)
-{
- core_environments_finalize (env);
- scm_gc_free (EXPORT_ENVIRONMENT (env), sizeof (struct export_environment),
- "export environment");
-}
-
-
-static int
-export_environment_print (SCM type, SCM port,
- scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<export environment ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-static struct scm_environment_funcs export_environment_funcs = {
- export_environment_ref,
- export_environment_fold,
- export_environment_define,
- export_environment_undefine,
- export_environment_set_x,
- export_environment_cell,
- core_environments_observe,
- core_environments_unobserve,
- export_environment_mark,
- export_environment_free,
- export_environment_print
-};
-
-
-void *scm_type_export_environment = &export_environment_funcs;
-
-
-static void
-export_environment_observer (SCM caller SCM_UNUSED, SCM export_env)
-{
- core_environments_broadcast (export_env);
-}
-
-
-SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0,
- (SCM private, SCM signature),
- "Return a new environment @var{exp} containing only those\n"
- "bindings in private whose symbols are present in\n"
- "@var{signature}. The @var{private} argument must be an\n"
- "environment.\n\n"
- "The environment @var{exp} binds symbol to location when\n"
- "@var{env} does, and symbol is exported by @var{signature}.\n\n"
- "@var{signature} is a list specifying which of the bindings in\n"
- "@var{private} should be visible in @var{exp}. Each element of\n"
- "@var{signature} should be a list of the form:\n"
- " (symbol attribute ...)\n"
- "where each attribute is one of the following:\n"
- "@table @asis\n"
- "@item the symbol @code{mutable-location}\n"
- " @var{exp} should treat the\n"
- " location bound to symbol as mutable. That is, @var{exp}\n"
- " will pass calls to @code{environment-set!} or\n"
- " @code{environment-cell} directly through to private.\n"
- "@item the symbol @code{immutable-location}\n"
- " @var{exp} should treat\n"
- " the location bound to symbol as immutable. If the program\n"
- " applies @code{environment-set!} to @var{exp} and symbol, or\n"
- " calls @code{environment-cell} to obtain a writable value\n"
- " cell, @code{environment-set!} will signal an\n"
- " @code{environment:immutable-location} error. Note that, even\n"
- " if an export environment treats a location as immutable, the\n"
- " underlying environment may treat it as mutable, so its\n"
- " value may change.\n"
- "@end table\n"
- "It is an error for an element of signature to specify both\n"
- "@code{mutable-location} and @code{immutable-location}. If\n"
- "neither is specified, @code{immutable-location} is assumed.\n\n"
- "As a special case, if an element of signature is a lone\n"
- "symbol @var{sym}, it is equivalent to an element of the form\n"
- "@code{(sym)}.\n\n"
- "All bindings in @var{exp} are immutable. If you apply\n"
- "@code{environment-define} or @code{environment-undefine} to\n"
- "@var{exp}, Guile will signal an\n"
- "@code{environment:immutable-binding} error. However,\n"
- "notice that the set of bindings in @var{exp} may still change,\n"
- "if the bindings in private change.")
-#define FUNC_NAME s_scm_make_export_environment
-{
- size_t size;
- struct export_environment *body;
- SCM env;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME);
-
- size = sizeof (struct export_environment);
- body = scm_gc_malloc (size, "export environment");
-
- core_environments_preinit (&body->base);
- body->private = SCM_BOOL_F;
- body->private_observer = SCM_BOOL_F;
- body->signature = SCM_BOOL_F;
-
- env = scm_make_environment (body);
-
- core_environments_init (&body->base, &export_environment_funcs);
- body->private = private;
- body->private_observer
- = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
- body->signature = SCM_EOL;
-
- scm_export_environment_set_signature_x (env, signature);
-
- return env;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0,
- (SCM object),
- "Return @code{#t} if object is an export environment, or\n"
- "@code{#f} otherwise.")
-#define FUNC_NAME s_scm_export_environment_p
-{
- return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0,
- (SCM env),
- "Return the private environment of export environment @var{env}.")
-#define FUNC_NAME s_scm_export_environment_private
-{
- SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return EXPORT_ENVIRONMENT (env)->private;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0,
- (SCM env, SCM private),
- "Change the private environment of export environment @var{env}.")
-#define FUNC_NAME s_scm_export_environment_set_private_x
-{
- struct export_environment *body;
-
- SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2, FUNC_NAME);
-
- body = EXPORT_ENVIRONMENT (env);
- SCM_ENVIRONMENT_UNOBSERVE (private, body->private_observer);
-
- body->private = private;
- body->private_observer
- = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0,
- (SCM env),
- "Return the signature of export environment @var{env}.")
-#define FUNC_NAME s_scm_export_environment_signature
-{
- SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return EXPORT_ENVIRONMENT (env)->signature;
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_parse_signature (SCM signature, const char* caller)
-{
- SCM result = SCM_EOL;
- SCM l;
-
- for (l = signature; scm_is_pair (l); l = SCM_CDR (l))
- {
- SCM entry = SCM_CAR (l);
-
- if (scm_is_symbol (entry))
- {
- SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL);
- result = scm_cons (new_entry, result);
- }
- else
- {
- SCM sym;
- SCM new_entry;
- int immutable = 0;
- int mutable = 0;
- SCM mutability;
- SCM l2;
-
- SCM_ASSERT (scm_is_pair (entry), entry, SCM_ARGn, caller);
- SCM_ASSERT (scm_is_symbol (SCM_CAR (entry)), entry, SCM_ARGn, caller);
-
- sym = SCM_CAR (entry);
-
- for (l2 = SCM_CDR (entry); scm_is_pair (l2); l2 = SCM_CDR (l2))
- {
- SCM attribute = SCM_CAR (l2);
- if (scm_is_eq (attribute, symbol_immutable_location))
- immutable = 1;
- else if (scm_is_eq (attribute, symbol_mutable_location))
- mutable = 1;
- else
- SCM_ASSERT (0, entry, SCM_ARGn, caller);
- }
- SCM_ASSERT (scm_is_null (l2), entry, SCM_ARGn, caller);
- SCM_ASSERT (!mutable || !immutable, entry, SCM_ARGn, caller);
-
- if (!mutable && !immutable)
- immutable = 1;
-
- mutability = mutable ? symbol_mutable_location : symbol_immutable_location;
- new_entry = scm_cons2 (sym, mutability, SCM_EOL);
- result = scm_cons (new_entry, result);
- }
- }
- SCM_ASSERT (scm_is_null (l), signature, SCM_ARGn, caller);
-
- /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
- * are, however, no checks for symbols entered twice with contradicting
- * mutabilities. It would be nice, to implement this test, to be able to
- * call the sort functions conveniently from C.
- */
-
- return scm_reverse (result);
-}
-
-
-SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0,
- (SCM env, SCM signature),
- "Change the signature of export environment @var{env}.")
-#define FUNC_NAME s_scm_export_environment_set_signature_x
-{
- SCM parsed_sig;
-
- SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- parsed_sig = export_environment_parse_signature (signature, FUNC_NAME);
-
- EXPORT_ENVIRONMENT (env)->signature = parsed_sig;
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-\f
-
-void
-scm_environments_prehistory ()
-{
- /* create environment smob */
- scm_tc16_environment = scm_make_smob_type ("environment", 0);
- scm_set_smob_mark (scm_tc16_environment, environment_mark);
- scm_set_smob_free (scm_tc16_environment, environment_free);
- scm_set_smob_print (scm_tc16_environment, environment_print);
-
- /* create observer smob */
- scm_tc16_observer = scm_make_smob_type ("observer", 0);
- scm_set_smob_mark (scm_tc16_observer, observer_mark);
- scm_set_smob_print (scm_tc16_observer, observer_print);
-
- /* create system environment */
- scm_system_environment = scm_make_leaf_environment ();
- scm_permanent_object (scm_system_environment);
-}
-
-
-void
-scm_init_environments ()
-{
-#include "libguile/environments.x"
-}
-
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* classes: h_files */
-
-#ifndef SCM_ENVIRONMENTS_H
-#define SCM_ENVIRONMENTS_H
-
-/* Copyright (C) 1999,2000, 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
- */
-
-\f
-
-#include "libguile/__scm.h"
-
-\f
-
-/* The type for folding functions written in C. A function meant to be passed
- * to scm_c_environment_fold should have the type scm_environment_folder.
- */
-typedef SCM (*scm_environment_folder) (SCM data, SCM sym, SCM val, SCM tail);
-
-
-/* The type for observer functions written in C. A function meant to be
- * passed to scm_c_environment_observe should have the type
- * scm_environment_observer.
- */
-typedef void (*scm_environment_observer) (SCM env, SCM data);
-
-
-struct scm_environment_funcs {
- SCM (*ref) (SCM self, SCM symbol);
- SCM (*fold) (SCM self, scm_environment_folder proc, SCM data, SCM init);
-
- SCM (*define) (SCM self, SCM symbol, SCM value);
- SCM (*undefine) (SCM self, SCM symbol);
- SCM (*set) (SCM self, SCM symbol, SCM value);
-
- SCM (*cell) (SCM self, SCM symbol, int for_write);
- SCM (*observe) (SCM self, scm_environment_observer proc, SCM data, int weak_p);
- void (*unobserve) (SCM self, SCM token);
-
- SCM (*mark) (SCM self);
- void (*free) (SCM self);
- int (*print) (SCM self, SCM port, scm_print_state *pstate);
-};
-
-\f
-
-#define SCM_ENVIRONMENT_SUCCESS SCM_BOOL_T
-#define SCM_ENVIRONMENT_BINDING_IMMUTABLE scm_from_int (0)
-#define SCM_ENVIRONMENT_LOCATION_IMMUTABLE scm_from_int (1)
-#define SCM_ENVIRONMENT_LOCATION_NO_CELL SCM_BOOL_F
-
-SCM_API scm_t_bits scm_tc16_environment;
-
-#define SCM_ENVIRONMENT_P(x) \
- (!SCM_IMP (x) && SCM_CELL_TYPE (x) == scm_tc16_environment)
-#define SCM_ENVIRONMENT_FUNCS(env) \
- (*((struct scm_environment_funcs **) SCM_CELL_WORD_1 (env)))
-#define SCM_ENVIRONMENT_BOUND_P(env, symbol) \
- (!SCM_UNBNDP (SCM_ENVIRONMENT_REF (env, symbol)))
-#define SCM_ENVIRONMENT_REF(env, symbol) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->ref)) (env, symbol))
-#define SCM_ENVIRONMENT_FOLD(env, proc, data, init) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->fold)) (env, proc, data, init))
-#define SCM_ENVIRONMENT_DEFINE(env, symbol, value) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->define)) (env, symbol, value))
-#define SCM_ENVIRONMENT_UNDEFINE(env, symbol) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->undefine)) (env, symbol))
-#define SCM_ENVIRONMENT_SET(env, symbol, value) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->set)) (env, symbol, value))
-#define SCM_ENVIRONMENT_CELL(env, symbol, for_write) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->cell)) (env, symbol, for_write))
-#define SCM_ENVIRONMENT_OBSERVE(env, proc, data, weak_p) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->observe)) (env, proc, data, weak_p))
-#define SCM_ENVIRONMENT_UNOBSERVE(env, token) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->unobserve)) (env, token))
-
-SCM_API scm_t_bits scm_tc16_observer;
-
-#define SCM_OBSERVER_P(x) \
- (!SCM_IMP (x) && (SCM_CELL_TYPE (x) == scm_tc16_observer))
-#define SCM_OBSERVER_ENVIRONMENT(x) \
- (SCM_CELL_OBJECT_1 (x))
-#define SCM_OBSERVER_DATA(x) \
- (SCM_CELL_OBJECT_2 (x))
-#define SCM_OBSERVER_PROC(x) \
- ((scm_environment_observer) SCM_CELL_WORD_3 (x))
-
-SCM_API SCM scm_system_environment;
-
-SCM_API void scm_error_environment_unbound (const char *, SCM, SCM) SCM_NORETURN;
-SCM_API void scm_error_environment_immutable_binding (const char *, SCM, SCM) SCM_NORETURN;
-SCM_API void scm_error_environment_immutable_location (const char *, SCM, SCM) SCM_NORETURN;
-
-SCM_API SCM scm_make_environment (void *type);
-SCM_API SCM scm_environment_p (SCM env);
-SCM_API SCM scm_environment_bound_p (SCM env, SCM sym);
-SCM_API SCM scm_environment_ref (SCM env, SCM sym);
-SCM_API SCM scm_c_environment_ref (SCM env, SCM sym);
-SCM_API SCM scm_environment_fold (SCM env, SCM proc, SCM init);
-SCM_API SCM scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init);
-SCM_API SCM scm_environment_define (SCM env, SCM sym, SCM val);
-SCM_API SCM scm_environment_undefine (SCM env, SCM sym);
-SCM_API SCM scm_environment_set_x (SCM env, SCM sym, SCM val);
-SCM_API SCM scm_environment_cell (SCM env, SCM sym, SCM for_write);
-SCM_API SCM scm_c_environment_cell (SCM env, SCM sym, int for_write);
-SCM_API SCM scm_environment_observe (SCM env, SCM proc);
-SCM_API SCM scm_environment_observe_weak (SCM env, SCM proc);
-SCM_API SCM scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p);
-SCM_API SCM scm_environment_unobserve (SCM token);
-
-SCM_INTERNAL void scm_environments_prehistory (void);
-SCM_INTERNAL void scm_init_environments (void);
-
-\f
-
-SCM_API void *scm_type_leaf_environment;
-
-#define SCM_LEAF_ENVIRONMENT_P(env) \
- (SCM_ENVIRONMENT_P (env) \
- && SCM_ENVIRONMENT_FUNCS (env) == scm_type_leaf_environment)
-
-SCM_API SCM scm_make_leaf_environment (void);
-SCM_API SCM scm_leaf_environment_p (SCM env);
-
-\f
-
-SCM_API void *scm_type_eval_environment;
-
-#define SCM_EVAL_ENVIRONMENT_P(env) \
- (SCM_ENVIRONMENT_P (env) \
- && SCM_ENVIRONMENT_FUNCS (env) == scm_type_eval_environment)
-
-SCM_API SCM scm_make_eval_environment (SCM local, SCM imported);
-SCM_API SCM scm_eval_environment_p (SCM env);
-SCM_API SCM scm_eval_environment_local (SCM env);
-SCM_API SCM scm_eval_environment_set_local_x (SCM env, SCM local);
-SCM_API SCM scm_eval_environment_imported (SCM env);
-SCM_API SCM scm_eval_environment_set_imported_x (SCM env, SCM imported);
-
-\f
-
-SCM_API void *scm_type_import_environment;
-
-#define SCM_IMPORT_ENVIRONMENT_P(env) \
- (SCM_ENVIRONMENT_P (env) \
- && SCM_ENVIRONMENT_FUNCS (env) == scm_type_import_environment)
-
-SCM_API SCM scm_make_import_environment (SCM imports, SCM conflict_proc);
-SCM_API SCM scm_import_environment_p (SCM env);
-SCM_API SCM scm_import_environment_imports (SCM env);
-SCM_API SCM scm_import_environment_set_imports_x (SCM env, SCM imports);
-
-\f
-
-SCM_API void *scm_type_export_environment;
-
-#define SCM_EXPORT_ENVIRONMENT_P(env) \
- (SCM_ENVIRONMENT_P (env) \
- && SCM_ENVIRONMENT_FUNCS (env) == scm_type_export_environment)
-
-SCM_API SCM scm_make_export_environment (SCM private, SCM signature);
-SCM_API SCM scm_export_environment_p (SCM env);
-SCM_API SCM scm_export_environment_private (SCM env);
-SCM_API SCM scm_export_environment_set_private_x (SCM env, SCM private);
-SCM_API SCM scm_export_environment_signature (SCM env);
-SCM_API SCM scm_export_environment_set_signature_x (SCM env, SCM signature);
-
-#endif /* SCM_ENVIRONMENTS_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
#include "libguile/smob.h"
#include "libguile/arrays.h"
#include "libguile/vectors.h"
+#include "libguile/hashtab.h"
+#include "libguile/bytevectors.h"
#include "libguile/struct.h"
#include "libguile/goops.h"
-#include "libguile/objects.h"
#include "libguile/validate.h"
#include "libguile/eq.h"
#endif
\f
-SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr,
- (SCM x, SCM y),
+SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
"Return @code{#t} if @var{x} and @var{y} are the same object,\n"
"except for numbers and characters. For example,\n"
"\n"
"(define x (string->symbol \"foo\"))\n"
"(eq? x 'foo) @result{} #t\n"
"@end example")
-#define FUNC_NAME s_scm_eq_p
+#define FUNC_NAME s_scm_i_eq_p
{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (scm_is_pair (rest))
+ {
+ if (!scm_is_eq (x, y))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return scm_from_bool (scm_is_eq (x, y));
}
#undef FUNC_NAME
+SCM
+scm_eq_p (SCM x, SCM y)
+{
+ return scm_from_bool (scm_is_eq (x, y));
+}
+
/* We compare doubles in a special way for 'eqv?' to be able to
distinguish plus and minus zero and to identify NaNs.
*/
}
#include <stdio.h>
-SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
- (SCM x, SCM y),
+SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
"Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
"for characters and numbers the same value.\n"
"\n"
"(eqv? 3 (+ 1 2)) @result{} #t\n"
"(eqv? 1 1.0) @result{} #f\n"
"@end example")
-#define FUNC_NAME s_scm_eqv_p
+#define FUNC_NAME s_scm_i_eqv_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (!scm_is_true (scm_eqv_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_eqv_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_eqv_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_eqv_p
{
if (scm_is_eq (x, y))
return SCM_BOOL_T;
SCM_COMPLEX_IMAG (y)));
}
}
- if (SCM_UNPACK (g_scm_eqv_p))
- return scm_call_generic_2 (g_scm_eqv_p, x, y);
- else
- return SCM_BOOL_F;
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
-SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} if @var{x} and @var{y} are the same type, and\n"
- "their contents or value are equal.\n"
- "\n"
- "For a pair, string, vector or array, @code{equal?} compares the\n"
- "contents, and does so using using the same @code{equal?}\n"
- "recursively, so a deep structure can be traversed.\n"
- "\n"
- "@example\n"
- "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n"
- "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
- "@end example\n"
- "\n"
- "For other objects, @code{equal?} compares as per @code{eqv?},\n"
- "which means characters and numbers are compared by type and\n"
- "value (and like @code{eqv?}, exact and inexact numbers are not\n"
- "@code{equal?}, even if their value is the same).\n"
- "\n"
- "@example\n"
- "(equal? 3 (+ 1 2)) @result{} #t\n"
- "(equal? 1 1.0) @result{} #f\n"
- "@end example\n"
- "\n"
- "Hash tables are currently only compared as per @code{eq?}, so\n"
- "two different tables are not @code{equal?}, even if their\n"
- "contents are the same.\n"
- "\n"
- "@code{equal?} does not support circular data structures, it may\n"
- "go into an infinite loop if asked to compare two circular lists\n"
- "or similar.\n"
- "\n"
- "New application-defined object types (Smobs) have an\n"
- "@code{equalp} handler which is called by @code{equal?}. This\n"
- "lets an application traverse the contents or control what is\n"
- "considered @code{equal?} for two such objects. If there's no\n"
- "handler, the default is to just compare as per @code{eq?}.")
-#define FUNC_NAME s_scm_equal_p
+SCM scm_i_equal_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_equal_p, "equal?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if @var{x} and @var{y} are the same type, and\n"
+ "their contents or value are equal.\n"
+ "\n"
+ "For a pair, string, vector or array, @code{equal?} compares the\n"
+ "contents, and does so using using the same @code{equal?}\n"
+ "recursively, so a deep structure can be traversed.\n"
+ "\n"
+ "@example\n"
+ "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n"
+ "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
+ "@end example\n"
+ "\n"
+ "For other objects, @code{equal?} compares as per @code{eqv?},\n"
+ "which means characters and numbers are compared by type and\n"
+ "value (and like @code{eqv?}, exact and inexact numbers are not\n"
+ "@code{equal?}, even if their value is the same).\n"
+ "\n"
+ "@example\n"
+ "(equal? 3 (+ 1 2)) @result{} #t\n"
+ "(equal? 1 1.0) @result{} #f\n"
+ "@end example\n"
+ "\n"
+ "Hash tables are currently only compared as per @code{eq?}, so\n"
+ "two different tables are not @code{equal?}, even if their\n"
+ "contents are the same.\n"
+ "\n"
+ "@code{equal?} does not support circular data structures, it may\n"
+ "go into an infinite loop if asked to compare two circular lists\n"
+ "or similar.\n"
+ "\n"
+ "New application-defined object types (Smobs) have an\n"
+ "@code{equalp} handler which is called by @code{equal?}. This\n"
+ "lets an application traverse the contents or control what is\n"
+ "considered @code{equal?} for two such objects. If there's no\n"
+ "handler, the default is to just compare as per @code{eq?}.")
+#define FUNC_NAME s_scm_i_equal_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (!scm_is_true (scm_equal_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = SCM_CDR (rest);
+ }
+ return scm_equal_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM
+scm_equal_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_equal_p
{
SCM_CHECK_STACK;
tailrecurse:
}
if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string)
return scm_string_equal_p (x, y);
+ if (SCM_TYP7 (x) == scm_tc7_bytevector && SCM_TYP7 (y) == scm_tc7_bytevector)
+ return scm_bytevector_eq_p (x, y);
if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
{
int i = SCM_SMOBNUM (x);
case scm_tc7_wvect:
return scm_i_vector_equal_p (x, y);
}
+ /* Check equality between structs of equal type (see cell-type test above). */
+ if (SCM_STRUCTP (x))
+ {
+ if (SCM_INSTANCEP (x))
+ goto generic_equal;
+ else
+ return scm_i_struct_equalp (x, y);
+ }
- /* Check equality between structs of equal type (see cell-type test above)
- that are not GOOPS instances. GOOPS instances are treated via the
- generic function. */
- if ((SCM_STRUCTP (x)) && (!SCM_INSTANCEP (x)))
- return scm_i_struct_equalp (x, y);
-
+ /* Otherwise just return false. Dispatching to the generic is the wrong thing
+ here, as we can hit this case for any two objects of the same type that we
+ think are distinct, like different symbols. */
+ return SCM_BOOL_F;
+
generic_equal:
- if (SCM_UNPACK (g_scm_equal_p))
- return scm_call_generic_2 (g_scm_equal_p, x, y);
+ if (SCM_UNPACK (g_scm_i_equal_p))
+ return scm_call_generic_2 (g_scm_i_equal_p, x, y);
else
return SCM_BOOL_F;
}
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
- * 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
- */
-
-\f
-
-/* SECTION: This code is compiled once.
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <alloca.h>
-
-#include "libguile/__scm.h"
-
-#include <assert.h>
-#include "libguile/_scm.h"
-#include "libguile/alist.h"
-#include "libguile/async.h"
-#include "libguile/continuations.h"
-#include "libguile/debug.h"
-#include "libguile/deprecation.h"
-#include "libguile/dynwind.h"
-#include "libguile/eq.h"
-#include "libguile/feature.h"
-#include "libguile/fluids.h"
-#include "libguile/futures.h"
-#include "libguile/goops.h"
-#include "libguile/hash.h"
-#include "libguile/hashtab.h"
-#include "libguile/lang.h"
-#include "libguile/list.h"
-#include "libguile/macros.h"
-#include "libguile/modules.h"
-#include "libguile/objects.h"
-#include "libguile/ports.h"
-#include "libguile/print.h"
-#include "libguile/procprop.h"
-#include "libguile/programs.h"
-#include "libguile/root.h"
-#include "libguile/smob.h"
-#include "libguile/srcprop.h"
-#include "libguile/stackchk.h"
-#include "libguile/strings.h"
-#include "libguile/threads.h"
-#include "libguile/throw.h"
-#include "libguile/validate.h"
-#include "libguile/values.h"
-#include "libguile/vectors.h"
-#include "libguile/vm.h"
-
-#include "libguile/eval.h"
-#include "libguile/private-options.h"
-
-\f
-
-
-static SCM unmemoize_exprs (SCM expr, SCM env);
-static SCM canonicalize_define (SCM expr);
-static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
-static SCM unmemoize_builtin_macro (SCM expr, SCM env);
-static void ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
-static SCM ceval (SCM x, SCM env);
-static SCM deval (SCM x, SCM env);
-
-\f
-
-/* {Syntax Errors}
- *
- * This section defines the message strings for the syntax errors that can be
- * detected during memoization and the functions and macros that shall be
- * called by the memoizer code to signal syntax errors. */
-
-
-/* Syntax errors that can be detected during memoization: */
-
-/* Circular or improper lists do not form valid scheme expressions. If a
- * circular list or an improper list is detected in a place where a scheme
- * expression is expected, a 'Bad expression' error is signalled. */
-static const char s_bad_expression[] = "Bad expression";
-
-/* If a form is detected that holds a different number of expressions than are
- * required in that context, a 'Missing or extra expression' error is
- * signalled. */
-static const char s_expression[] = "Missing or extra expression in";
-
-/* If a form is detected that holds less expressions than are required in that
- * context, a 'Missing expression' error is signalled. */
-static const char s_missing_expression[] = "Missing expression in";
-
-/* If a form is detected that holds more expressions than are allowed in that
- * context, an 'Extra expression' error is signalled. */
-static const char s_extra_expression[] = "Extra expression in";
-
-/* The empty combination '()' is not allowed as an expression in scheme. If
- * it is detected in a place where an expression is expected, an 'Illegal
- * empty combination' error is signalled. Note: If you encounter this error
- * message, it is very likely that you intended to denote the empty list. To
- * do so, you need to quote the empty list like (quote ()) or '(). */
-static const char s_empty_combination[] = "Illegal empty combination";
-
-/* A body may hold an arbitrary number of internal defines, followed by a
- * non-empty sequence of expressions. If a body with an empty sequence of
- * expressions is detected, a 'Missing body expression' error is signalled.
- */
-static const char s_missing_body_expression[] = "Missing body expression in";
-
-/* A body may hold an arbitrary number of internal defines, followed by a
- * non-empty sequence of expressions. Each the definitions and the
- * expressions may be grouped arbitraryly with begin, but it is not allowed to
- * mix definitions and expressions. If a define form in a body mixes
- * definitions and expressions, a 'Mixed definitions and expressions' error is
- * signalled. */
-static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
-/* Definitions are only allowed on the top level and at the start of a body.
- * If a definition is detected anywhere else, a 'Bad define placement' error
- * is signalled. */
-static const char s_bad_define[] = "Bad define placement";
-
-/* Case or cond expressions must have at least one clause. If a case or cond
- * expression without any clauses is detected, a 'Missing clauses' error is
- * signalled. */
-static const char s_missing_clauses[] = "Missing clauses";
-
-/* If there is an 'else' clause in a case or a cond statement, it must be the
- * last clause. If after the 'else' case clause further clauses are detected,
- * a 'Misplaced else clause' error is signalled. */
-static const char s_misplaced_else_clause[] = "Misplaced else clause";
-
-/* If a case clause is detected that is not in the format
- * (<label(s)> <expression1> <expression2> ...)
- * a 'Bad case clause' error is signalled. */
-static const char s_bad_case_clause[] = "Bad case clause";
-
-/* If a case clause is detected where the <label(s)> element is neither a
- * proper list nor (in case of the last clause) the syntactic keyword 'else',
- * a 'Bad case labels' error is signalled. Note: If you encounter this error
- * for an else-clause which seems to be syntactically correct, check if 'else'
- * is really a syntactic keyword in that context. If 'else' is bound in the
- * local or global environment, it is not considered a syntactic keyword, but
- * will be treated as any other variable. */
-static const char s_bad_case_labels[] = "Bad case labels";
-
-/* In a case statement all labels have to be distinct. If in a case statement
- * a label occurs more than once, a 'Duplicate case label' error is
- * signalled. */
-static const char s_duplicate_case_label[] = "Duplicate case label";
-
-/* If a cond clause is detected that is not in one of the formats
- * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
- * a 'Bad cond clause' error is signalled. */
-static const char s_bad_cond_clause[] = "Bad cond clause";
-
-/* If a cond clause is detected that uses the alternate '=>' form, but does
- * not hold a recipient element for the test result, a 'Missing recipient'
- * error is signalled. */
-static const char s_missing_recipient[] = "Missing recipient in";
-
-/* If in a position where a variable name is required some other object is
- * detected, a 'Bad variable' error is signalled. */
-static const char s_bad_variable[] = "Bad variable";
-
-/* Bindings for forms like 'let' and 'do' have to be given in a proper,
- * possibly empty list. If any other object is detected in a place where a
- * list of bindings was required, a 'Bad bindings' error is signalled. */
-static const char s_bad_bindings[] = "Bad bindings";
-
-/* Depending on the syntactic context, a binding has to be in the format
- * (<variable> <expression>) or (<variable> <expression1> <expression2>).
- * If anything else is detected in a place where a binding was expected, a
- * 'Bad binding' error is signalled. */
-static const char s_bad_binding[] = "Bad binding";
-
-/* Some syntactic forms don't allow variable names to appear more than once in
- * a list of bindings. If such a situation is nevertheless detected, a
- * 'Duplicate binding' error is signalled. */
-static const char s_duplicate_binding[] = "Duplicate binding";
-
-/* If the exit form of a 'do' expression is not in the format
- * (<test> <expression> ...)
- * a 'Bad exit clause' error is signalled. */
-static const char s_bad_exit_clause[] = "Bad exit clause";
-
-/* The formal function arguments of a lambda expression have to be either a
- * single symbol or a non-cyclic list. For anything else a 'Bad formals'
- * error is signalled. */
-static const char s_bad_formals[] = "Bad formals";
-
-/* If in a lambda expression something else than a symbol is detected at a
- * place where a formal function argument is required, a 'Bad formal' error is
- * signalled. */
-static const char s_bad_formal[] = "Bad formal";
-
-/* If in the arguments list of a lambda expression an argument name occurs
- * more than once, a 'Duplicate formal' error is signalled. */
-static const char s_duplicate_formal[] = "Duplicate formal";
-
-/* If the evaluation of an unquote-splicing expression gives something else
- * than a proper list, a 'Non-list result for unquote-splicing' error is
- * signalled. */
-static const char s_splicing[] = "Non-list result for unquote-splicing";
-
-/* If something else than an exact integer is detected as the argument for
- * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
-static const char s_bad_slot_number[] = "Bad slot number";
-
-
-/* Signal a syntax error. We distinguish between the form that caused the
- * error and the enclosing expression. The error message will print out as
- * shown in the following pattern. The file name and line number are only
- * given when they can be determined from the erroneous form or from the
- * enclosing expression.
- *
- * <filename>: In procedure memoization:
- * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
-
-SCM_SYMBOL (syntax_error_key, "syntax-error");
-
-/* The prototype is needed to indicate that the function does not return. */
-static void
-syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
-
-static void
-syntax_error (const char* const msg, const SCM form, const SCM expr)
-{
- SCM msg_string = scm_from_locale_string (msg);
- SCM filename = SCM_BOOL_F;
- SCM linenr = SCM_BOOL_F;
- const char *format;
- SCM args;
-
- if (scm_is_pair (form))
- {
- filename = scm_source_property (form, scm_sym_filename);
- linenr = scm_source_property (form, scm_sym_line);
- }
-
- if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
- {
- filename = scm_source_property (expr, scm_sym_filename);
- linenr = scm_source_property (expr, scm_sym_line);
- }
-
- if (!SCM_UNBNDP (expr))
- {
- if (scm_is_true (filename))
- {
- format = "In file ~S, line ~S: ~A ~S in expression ~S.";
- args = scm_list_5 (filename, linenr, msg_string, form, expr);
- }
- else if (scm_is_true (linenr))
- {
- format = "In line ~S: ~A ~S in expression ~S.";
- args = scm_list_4 (linenr, msg_string, form, expr);
- }
- else
- {
- format = "~A ~S in expression ~S.";
- args = scm_list_3 (msg_string, form, expr);
- }
- }
- else
- {
- if (scm_is_true (filename))
- {
- format = "In file ~S, line ~S: ~A ~S.";
- args = scm_list_4 (filename, linenr, msg_string, form);
- }
- else if (scm_is_true (linenr))
- {
- format = "In line ~S: ~A ~S.";
- args = scm_list_3 (linenr, msg_string, form);
- }
- else
- {
- format = "~A ~S.";
- args = scm_list_2 (msg_string, form);
- }
- }
-
- scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
-}
-
-
-/* Shortcut macros to simplify syntax error handling. */
-#define ASSERT_SYNTAX(cond, message, form) \
- { if (SCM_UNLIKELY (!(cond))) \
- syntax_error (message, form, SCM_UNDEFINED); }
-#define ASSERT_SYNTAX_2(cond, message, form, expr) \
- { if (SCM_UNLIKELY (!(cond))) \
- syntax_error (message, form, expr); }
-
-static void error_unbound_variable (SCM symbol) SCM_NORETURN;
-static void error_defined_variable (SCM symbol) SCM_NORETURN;
-
-\f
-
-/* {Ilocs}
- *
- * Ilocs are memoized references to variables in local environment frames.
- * They are represented as three values: The relative offset of the
- * environment frame, the number of the binding within that frame, and a
- * boolean value indicating whether the binding is the last binding in the
- * frame.
- *
- * Frame numbers have 11 bits, relative offsets have 12 bits.
- */
-
-#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
-#define SCM_IFRINC (0x00000100L)
-#define SCM_ICDR (0x00080000L)
-#define SCM_IDINC (0x00100000L)
-#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
- & (SCM_UNPACK (n) >> 8))
-#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
-#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
-#define SCM_IDSTMSK (-SCM_IDINC)
-#define SCM_IFRAMEMAX ((1<<11)-1)
-#define SCM_IDISTMAX ((1<<12)-1)
-#define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
- SCM_PACK ( \
- ((frame_nr) << 8) \
- + ((binding_nr) << 20) \
- + ((last_p) ? SCM_ICDR : 0) \
- + scm_tc8_iloc )
-
-void
-scm_i_print_iloc (SCM iloc, SCM port)
-{
- scm_puts ("#@", port);
- scm_intprint ((long) SCM_IFRAME (iloc), 10, port);
- scm_putc (SCM_ICDRP (iloc) ? '-' : '+', port);
- scm_intprint ((long) SCM_IDIST (iloc), 10, port);
-}
-
-#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
-
-SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp);
-
-SCM_DEFINE (scm_dbg_make_iloc, "dbg-make-iloc", 3, 0, 0,
- (SCM frame, SCM binding, SCM cdrp),
- "Return a new iloc with frame offset @var{frame}, binding\n"
- "offset @var{binding} and the cdr flag @var{cdrp}.")
-#define FUNC_NAME s_scm_dbg_make_iloc
-{
- return SCM_MAKE_ILOC ((scm_t_bits) scm_to_unsigned_integer (frame, 0, SCM_IFRAMEMAX),
- (scm_t_bits) scm_to_unsigned_integer (binding, 0, SCM_IDISTMAX),
- scm_is_true (cdrp));
-}
-#undef FUNC_NAME
-
-SCM scm_dbg_iloc_p (SCM obj);
-
-SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is an iloc.")
-#define FUNC_NAME s_scm_dbg_iloc_p
-{
- return scm_from_bool (SCM_ILOCP (obj));
-}
-#undef FUNC_NAME
-
-#endif
-
-\f
-
-/* {Evaluator byte codes (isyms)}
- */
-
-#define ISYMNUM(n) (SCM_ITAG8_DATA (n))
-
-/* This table must agree with the list of SCM_IM_ constants in tags.h */
-static const char *const isymnames[] =
-{
- "#@and",
- "#@begin",
- "#@case",
- "#@cond",
- "#@do",
- "#@if",
- "#@lambda",
- "#@let",
- "#@let*",
- "#@letrec",
- "#@or",
- "#@quote",
- "#@set!",
- "#@define",
- "#@apply",
- "#@call-with-current-continuation",
- "#@dispatch",
- "#@slot-ref",
- "#@slot-set!",
- "#@delay",
- "#@future",
- "#@call-with-values",
- "#@else",
- "#@arrow",
- "#@nil-cond",
- "#@bind"
-};
-
-void
-scm_i_print_isym (SCM isym, SCM port)
-{
- const size_t isymnum = ISYMNUM (isym);
- if (isymnum < (sizeof isymnames / sizeof (char *)))
- scm_puts (isymnames[isymnum], port);
- else
- scm_ipruk ("isym", isym, port);
-}
-
-\f
-
-/* The function lookup_symbol is used during memoization: Lookup the symbol in
- * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
- * returned. If the symbol is a global variable, the variable object to which
- * the symbol is bound is returned. Finally, if the symbol is a local
- * variable the corresponding iloc object is returned. */
-
-/* A helper function for lookup_symbol: Try to find the symbol in the top
- * level environment frame. The function returns SCM_UNDEFINED if the symbol
- * is unbound and it returns a variable object if the symbol is a global
- * variable. */
-static SCM
-lookup_global_symbol (const SCM symbol, const SCM top_level)
-{
- const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
- if (scm_is_false (variable))
- return SCM_UNDEFINED;
- else
- return variable;
-}
-
-static SCM
-lookup_symbol (const SCM symbol, const SCM env)
-{
- SCM frame_idx;
- unsigned int frame_nr;
-
- for (frame_idx = env, frame_nr = 0;
- !scm_is_null (frame_idx);
- frame_idx = SCM_CDR (frame_idx), ++frame_nr)
- {
- const SCM frame = SCM_CAR (frame_idx);
- if (scm_is_pair (frame))
- {
- /* frame holds a local environment frame */
- SCM symbol_idx;
- unsigned int symbol_nr;
-
- for (symbol_idx = SCM_CAR (frame), symbol_nr = 0;
- scm_is_pair (symbol_idx);
- symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr)
- {
- if (scm_is_eq (SCM_CAR (symbol_idx), symbol))
- /* found the symbol, therefore return the iloc */
- return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0);
- }
- if (scm_is_eq (symbol_idx, symbol))
- /* found the symbol as the last element of the current frame */
- return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1);
- }
- else
- {
- /* no more local environment frames */
- return lookup_global_symbol (symbol, frame);
- }
- }
-
- return lookup_global_symbol (symbol, SCM_BOOL_F);
-}
-
-
-/* Return true if the symbol is - from the point of view of a macro
- * transformer - a literal in the sense specified in chapter "pattern
- * language" of R5RS. In the code below, however, we don't match the
- * definition of R5RS exactly: It returns true if the identifier has no
- * binding or if it is a syntactic keyword. */
-static int
-literal_p (const SCM symbol, const SCM env)
-{
- const SCM variable = lookup_symbol (symbol, env);
- if (SCM_UNBNDP (variable))
- return 1;
- if (SCM_VARIABLEP (variable) && SCM_MACROP (SCM_VARIABLE_REF (variable)))
- return 1;
- else
- return 0;
-}
-
-
-/* Return true if the expression is self-quoting in the memoized code. Thus,
- * some other objects (like e. g. vectors) are reported as self-quoting, which
- * according to R5RS would need to be quoted. */
-static int
-is_self_quoting_p (const SCM expr)
-{
- if (scm_is_pair (expr))
- return 0;
- else if (scm_is_symbol (expr))
- return 0;
- else if (scm_is_null (expr))
- return 0;
- else return 1;
-}
-
-
-SCM_SYMBOL (sym_three_question_marks, "???");
-
-static SCM
-unmemoize_expression (const SCM expr, const SCM env)
-{
- if (SCM_ILOCP (expr))
- {
- SCM frame_idx;
- unsigned long int frame_nr;
- SCM symbol_idx;
- unsigned long int symbol_nr;
-
- for (frame_idx = env, frame_nr = SCM_IFRAME (expr);
- frame_nr != 0;
- frame_idx = SCM_CDR (frame_idx), --frame_nr)
- ;
- for (symbol_idx = SCM_CAAR (frame_idx), symbol_nr = SCM_IDIST (expr);
- symbol_nr != 0;
- symbol_idx = SCM_CDR (symbol_idx), --symbol_nr)
- ;
- return SCM_ICDRP (expr) ? symbol_idx : SCM_CAR (symbol_idx);
- }
- else if (SCM_VARIABLEP (expr))
- {
- const SCM sym = scm_module_reverse_lookup (scm_env_module (env), expr);
- return scm_is_true (sym) ? sym : sym_three_question_marks;
- }
- else if (scm_is_simple_vector (expr))
- {
- return scm_list_2 (scm_sym_quote, expr);
- }
- else if (!scm_is_pair (expr))
- {
- return expr;
- }
- else if (SCM_ISYMP (SCM_CAR (expr)))
- {
- return unmemoize_builtin_macro (expr, env);
- }
- else
- {
- return unmemoize_exprs (expr, env);
- }
-}
-
-
-static SCM
-unmemoize_exprs (const SCM exprs, const SCM env)
-{
- SCM r_result = SCM_EOL;
- SCM expr_idx = exprs;
- SCM um_expr;
-
- /* Note that due to the current lazy memoizer we may find partially memoized
- * code during execution. In such code we have to expect improper lists of
- * expressions: On the one hand, for such code syntax checks have not yet
- * fully been performed, on the other hand, there may be even legal code
- * like '(a . b) appear as an improper list of expressions as long as the
- * quote expression is still in its unmemoized form. For this reason, the
- * following code handles improper lists of expressions until memoization
- * and execution have been completely separated. */
- for (; scm_is_pair (expr_idx); expr_idx = SCM_CDR (expr_idx))
- {
- const SCM expr = SCM_CAR (expr_idx);
-
- /* In partially memoized code, lists of expressions that stem from a
- * body form may start with an ISYM if the body itself has not yet been
- * memoized. This isym is just an internal marker to indicate that the
- * body still needs to be memoized. An isym may occur at the very
- * beginning of the body or after one or more comment strings. It is
- * dropped during unmemoization. */
- if (!SCM_ISYMP (expr))
- {
- um_expr = unmemoize_expression (expr, env);
- r_result = scm_cons (um_expr, r_result);
- }
- }
- um_expr = unmemoize_expression (expr_idx, env);
- if (!scm_is_null (r_result))
- {
- const SCM result = scm_reverse_x (r_result, SCM_UNDEFINED);
- SCM_SETCDR (r_result, um_expr);
- return result;
- }
- else
- {
- return um_expr;
- }
-}
-
-
-/* Rewrite the body (which is given as the list of expressions forming the
- * body) into its internal form. The internal form of a body (<expr> ...) is
- * just the body itself, but prefixed with an ISYM that denotes to what kind
- * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
- * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
- * SCM_IM_LET, etc.
- *
- * It is assumed that the calling expression has already made sure that the
- * body is a proper list. */
-static SCM
-m_body (SCM op, SCM exprs)
-{
- /* Don't add another ISYM if one is present already. */
- if (SCM_ISYMP (SCM_CAR (exprs)))
- return exprs;
- else
- return scm_cons (op, exprs);
-}
-
-
-/* The function m_expand_body memoizes a proper list of expressions forming a
- * body. This function takes care of dealing with internal defines and
- * transforming them into an equivalent letrec expression. The list of
- * expressions is rewritten in place. */
-
-/* This is a helper function for m_expand_body. If the argument expression is
- * a symbol that denotes a syntactic keyword, the corresponding macro object
- * is returned, in all other cases the function returns SCM_UNDEFINED. */
-static SCM
-try_macro_lookup (const SCM expr, const SCM env)
-{
- if (scm_is_symbol (expr))
- {
- const SCM variable = lookup_symbol (expr, env);
- if (SCM_VARIABLEP (variable))
- {
- const SCM value = SCM_VARIABLE_REF (variable);
- if (SCM_MACROP (value))
- return value;
- }
- }
-
- return SCM_UNDEFINED;
-}
-
-/* This is a helper function for m_expand_body. It expands user macros,
- * because for the correct translation of a body we need to know whether they
- * expand to a definition. */
-static SCM
-expand_user_macros (SCM expr, const SCM env)
-{
- while (scm_is_pair (expr))
- {
- const SCM car_expr = SCM_CAR (expr);
- const SCM new_car = expand_user_macros (car_expr, env);
- const SCM value = try_macro_lookup (new_car, env);
-
- if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2)
- {
- /* User macros transform code into code. */
- expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env);
- /* We need to reiterate on the transformed code. */
- }
- else
- {
- /* No user macro: return. */
- SCM_SETCAR (expr, new_car);
- return expr;
- }
- }
-
- return expr;
-}
-
-/* This is a helper function for m_expand_body. It determines if a given form
- * represents an application of a given built-in macro. The built-in macro to
- * check for is identified by its syntactic keyword. The form is an
- * application of the given macro if looking up the car of the form in the
- * given environment actually returns the built-in macro. */
-static int
-is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
-{
- if (scm_is_pair (form))
- {
- const SCM car_form = SCM_CAR (form);
- const SCM value = try_macro_lookup (car_form, env);
- if (SCM_BUILTIN_MACRO_P (value))
- {
- const SCM macro_name = scm_macro_name (value);
- return scm_is_eq (macro_name, syntactic_keyword);
- }
- }
-
- return 0;
-}
-
-static SCM
-macroexp (SCM x, SCM env)
-{
- SCM res, proc, orig_sym;
-
- /* Don't bother to produce error messages here. We get them when we
- eventually execute the code for real. */
-
- macro_tail:
- orig_sym = SCM_CAR (x);
- if (!scm_is_symbol (orig_sym))
- return x;
-
- {
- SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
- if (proc_ptr == NULL)
- {
- /* We have lost the race. */
- goto macro_tail;
- }
- proc = *proc_ptr;
- }
-
- /* Only handle memoizing macros. `Acros' and `macros' are really
- special forms and should not be evaluated here. */
-
- if (!SCM_MACROP (proc)
- || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
- return x;
-
- SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
- res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
-
- if (scm_ilength (res) <= 0)
- /* Result of expansion is not a list. */
- return (scm_list_2 (SCM_IM_BEGIN, res));
- else
- {
- /* njrev: Several queries here: (1) I don't see how it can be
- correct that the SCM_SETCAR 2 lines below this comment needs
- protection, but the SCM_SETCAR 6 lines above does not, so
- something here is probably wrong. (2) macroexp() is now only
- used in one place - scm_m_generalized_set_x - whereas all other
- macro expansion happens through expand_user_macros. Therefore
- (2.1) perhaps macroexp() could be eliminated completely now?
- (2.2) Does expand_user_macros need any critical section
- protection? */
-
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (res));
- SCM_SETCDR (x, SCM_CDR (res));
- SCM_CRITICAL_SECTION_END;
-
- goto macro_tail;
- }
-}
-
-\f
-/* Start of the memoizers for the standard R5RS builtin macros. */
-
-static SCM scm_m_quote (SCM xorig, SCM env);
-static SCM scm_m_begin (SCM xorig, SCM env);
-static SCM scm_m_if (SCM xorig, SCM env);
-static SCM scm_m_set_x (SCM xorig, SCM env);
-static SCM scm_m_and (SCM xorig, SCM env);
-static SCM scm_m_or (SCM xorig, SCM env);
-static SCM scm_m_case (SCM xorig, SCM env);
-static SCM scm_m_cond (SCM xorig, SCM env);
-static SCM scm_m_lambda (SCM xorig, SCM env);
-static SCM scm_m_letstar (SCM xorig, SCM env);
-static SCM scm_m_do (SCM xorig, SCM env);
-static SCM scm_m_quasiquote (SCM xorig, SCM env);
-static SCM scm_m_delay (SCM xorig, SCM env);
-static SCM scm_m_generalized_set_x (SCM xorig, SCM env);
-#if 0 /* Futures are disabled, see "futures.h". */
-static SCM scm_m_future (SCM xorig, SCM env);
-#endif
-static SCM scm_m_define (SCM x, SCM env);
-static SCM scm_m_letrec (SCM xorig, SCM env);
-static SCM scm_m_let (SCM xorig, SCM env);
-static SCM scm_m_at (SCM xorig, SCM env);
-static SCM scm_m_atat (SCM xorig, SCM env);
-static SCM scm_m_atslot_ref (SCM xorig, SCM env);
-static SCM scm_m_atslot_set_x (SCM xorig, SCM env);
-static SCM scm_m_apply (SCM xorig, SCM env);
-static SCM scm_m_cont (SCM xorig, SCM env);
-#if SCM_ENABLE_ELISP
-static SCM scm_m_nil_cond (SCM xorig, SCM env);
-static SCM scm_m_atfop (SCM xorig, SCM env);
-#endif /* SCM_ENABLE_ELISP */
-static SCM scm_m_atbind (SCM xorig, SCM env);
-static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
-static SCM scm_m_eval_when (SCM xorig, SCM env);
-
-
-static void
-m_expand_body (const SCM forms, const SCM env)
-{
- /* The first body form can be skipped since it is known to be the ISYM that
- * was prepended to the body by m_body. */
- SCM cdr_forms = SCM_CDR (forms);
- SCM form_idx = cdr_forms;
- SCM definitions = SCM_EOL;
- SCM sequence = SCM_EOL;
-
- /* According to R5RS, the list of body forms consists of two parts: a number
- * (maybe zero) of definitions, followed by a non-empty sequence of
- * expressions. Each the definitions and the expressions may be grouped
- * arbitrarily with begin, but it is not allowed to mix definitions and
- * expressions. The task of the following loop therefore is to split the
- * list of body forms into the list of definitions and the sequence of
- * expressions. */
- while (!scm_is_null (form_idx))
- {
- const SCM form = SCM_CAR (form_idx);
- const SCM new_form = expand_user_macros (form, env);
- if (is_system_macro_p (scm_sym_define, new_form, env))
- {
- definitions = scm_cons (new_form, definitions);
- form_idx = SCM_CDR (form_idx);
- }
- else if (is_system_macro_p (scm_sym_begin, new_form, env))
- {
- /* We have encountered a group of forms. This has to be either a
- * (possibly empty) group of (possibly further grouped) definitions,
- * or a non-empty group of (possibly further grouped)
- * expressions. */
- const SCM grouped_forms = SCM_CDR (new_form);
- unsigned int found_definition = 0;
- unsigned int found_expression = 0;
- SCM grouped_form_idx = grouped_forms;
- while (!found_expression && !scm_is_null (grouped_form_idx))
- {
- const SCM inner_form = SCM_CAR (grouped_form_idx);
- const SCM new_inner_form = expand_user_macros (inner_form, env);
- if (is_system_macro_p (scm_sym_define, new_inner_form, env))
- {
- found_definition = 1;
- definitions = scm_cons (new_inner_form, definitions);
- grouped_form_idx = SCM_CDR (grouped_form_idx);
- }
- else if (is_system_macro_p (scm_sym_begin, new_inner_form, env))
- {
- const SCM inner_group = SCM_CDR (new_inner_form);
- grouped_form_idx
- = scm_append (scm_list_2 (inner_group,
- SCM_CDR (grouped_form_idx)));
- }
- else
- {
- /* The group marks the start of the expressions of the body.
- * We have to make sure that within the same group we have
- * not encountered a definition before. */
- ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form);
- found_expression = 1;
- grouped_form_idx = SCM_EOL;
- }
- }
-
- /* We have finished processing the group. If we have not yet
- * encountered an expression we continue processing the forms of the
- * body to collect further definition forms. Otherwise, the group
- * marks the start of the sequence of expressions of the body. */
- if (!found_expression)
- {
- form_idx = SCM_CDR (form_idx);
- }
- else
- {
- sequence = form_idx;
- form_idx = SCM_EOL;
- }
- }
- else
- {
- /* We have detected a form which is no definition. This marks the
- * start of the sequence of expressions of the body. */
- sequence = form_idx;
- form_idx = SCM_EOL;
- }
- }
-
- /* FIXME: forms does not hold information about the file location. */
- ASSERT_SYNTAX (scm_is_pair (sequence), s_missing_body_expression, cdr_forms);
-
- if (!scm_is_null (definitions))
- {
- SCM definition_idx;
- SCM letrec_tail;
- SCM letrec_expression;
- SCM new_letrec_expression;
-
- SCM bindings = SCM_EOL;
- for (definition_idx = definitions;
- !scm_is_null (definition_idx);
- definition_idx = SCM_CDR (definition_idx))
- {
- const SCM definition = SCM_CAR (definition_idx);
- const SCM canonical_definition = canonicalize_define (definition);
- const SCM binding = SCM_CDR (canonical_definition);
- bindings = scm_cons (binding, bindings);
- };
-
- letrec_tail = scm_cons (bindings, sequence);
- /* FIXME: forms does not hold information about the file location. */
- letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail);
- new_letrec_expression = scm_m_letrec (letrec_expression, env);
- SCM_SETCAR (forms, new_letrec_expression);
- SCM_SETCDR (forms, SCM_EOL);
- }
- else
- {
- SCM_SETCAR (forms, SCM_CAR (sequence));
- SCM_SETCDR (forms, SCM_CDR (sequence));
- }
-}
-
-SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
-SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
-
-static SCM
-scm_m_and (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
-
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
-
- if (length == 0)
- {
- /* Special case: (and) is replaced by #t. */
- return SCM_BOOL_T;
- }
- else
- {
- SCM_SETCAR (expr, SCM_IM_AND);
- return expr;
- }
-}
-
-static SCM
-unmemoize_and (const SCM expr, const SCM env)
-{
- return scm_cons (scm_sym_and, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
-SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
-
-static SCM
-scm_m_begin (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
- * That means, there should be a distinction between uses of begin where an
- * empty clause is OK and where it is not. */
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_BEGIN);
- return expr;
-}
-
-static SCM
-unmemoize_begin (const SCM expr, const SCM env)
-{
- return scm_cons (scm_sym_begin, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
-SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
-SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
-
-static SCM
-scm_m_case (SCM expr, SCM env)
-{
- SCM clauses;
- SCM all_labels = SCM_EOL;
-
- /* Check, whether 'else is a literal, i. e. not bound to a value. */
- const int else_literal_p = literal_p (scm_sym_else, env);
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr);
-
- clauses = SCM_CDR (cdr_expr);
- while (!scm_is_null (clauses))
- {
- SCM labels;
-
- const SCM clause = SCM_CAR (clauses);
- ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2,
- s_bad_case_clause, clause, expr);
-
- labels = SCM_CAR (clause);
- if (scm_is_pair (labels))
- {
- ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0,
- s_bad_case_labels, labels, expr);
- all_labels = scm_append (scm_list_2 (labels, all_labels));
- }
- else if (scm_is_null (labels))
- {
- /* The list of labels is empty. According to R5RS this is allowed.
- * It means that the sequence of expressions will never be executed.
- * Therefore, as an optimization, we could remove the whole
- * clause. */
- }
- else
- {
- ASSERT_SYNTAX_2 (scm_is_eq (labels, scm_sym_else) && else_literal_p,
- s_bad_case_labels, labels, expr);
- ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses)),
- s_misplaced_else_clause, clause, expr);
- }
-
- /* build the new clause */
- if (scm_is_eq (labels, scm_sym_else))
- SCM_SETCAR (clause, SCM_IM_ELSE);
-
- clauses = SCM_CDR (clauses);
- }
-
- /* Check whether all case labels are distinct. */
- for (; !scm_is_null (all_labels); all_labels = SCM_CDR (all_labels))
- {
- const SCM label = SCM_CAR (all_labels);
- ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label, SCM_CDR (all_labels))),
- s_duplicate_case_label, label, expr);
- }
-
- SCM_SETCAR (expr, SCM_IM_CASE);
- return expr;
-}
-
-static SCM
-unmemoize_case (const SCM expr, const SCM env)
-{
- const SCM um_key_expr = unmemoize_expression (SCM_CADR (expr), env);
- SCM um_clauses = SCM_EOL;
- SCM clause_idx;
-
- for (clause_idx = SCM_CDDR (expr);
- !scm_is_null (clause_idx);
- clause_idx = SCM_CDR (clause_idx))
- {
- const SCM clause = SCM_CAR (clause_idx);
- const SCM labels = SCM_CAR (clause);
- const SCM exprs = SCM_CDR (clause);
-
- const SCM um_exprs = unmemoize_exprs (exprs, env);
- const SCM um_labels = (scm_is_eq (labels, SCM_IM_ELSE))
- ? scm_sym_else
- : scm_i_finite_list_copy (labels);
- const SCM um_clause = scm_cons (um_labels, um_exprs);
-
- um_clauses = scm_cons (um_clause, um_clauses);
- }
- um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
-
- return scm_cons2 (scm_sym_case, um_key_expr, um_clauses);
-}
-
-
-SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
-SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
-SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
-
-static SCM
-scm_m_cond (SCM expr, SCM env)
-{
- /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
- const int else_literal_p = literal_p (scm_sym_else, env);
- const int arrow_literal_p = literal_p (scm_sym_arrow, env);
-
- const SCM clauses = SCM_CDR (expr);
- SCM clause_idx;
-
- ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
-
- for (clause_idx = clauses;
- !scm_is_null (clause_idx);
- clause_idx = SCM_CDR (clause_idx))
- {
- SCM test;
-
- const SCM clause = SCM_CAR (clause_idx);
- const long length = scm_ilength (clause);
- ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
-
- test = SCM_CAR (clause);
- if (scm_is_eq (test, scm_sym_else) && else_literal_p)
- {
- const int last_clause_p = scm_is_null (SCM_CDR (clause_idx));
- ASSERT_SYNTAX_2 (length >= 2,
- s_bad_cond_clause, clause, expr);
- ASSERT_SYNTAX_2 (last_clause_p,
- s_misplaced_else_clause, clause, expr);
- SCM_SETCAR (clause, SCM_IM_ELSE);
- }
- else if (length >= 2
- && scm_is_eq (SCM_CADR (clause), scm_sym_arrow)
- && arrow_literal_p)
- {
- ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
- ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
- SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW);
- }
- /* SRFI 61 extended cond */
- else if (length >= 3
- && scm_is_eq (SCM_CADDR (clause), scm_sym_arrow)
- && arrow_literal_p)
- {
- ASSERT_SYNTAX_2 (length > 3, s_missing_recipient, clause, expr);
- ASSERT_SYNTAX_2 (length == 4, s_extra_expression, clause, expr);
- SCM_SETCAR (SCM_CDDR (clause), SCM_IM_ARROW);
- }
- }
-
- SCM_SETCAR (expr, SCM_IM_COND);
- return expr;
-}
-
-static SCM
-unmemoize_cond (const SCM expr, const SCM env)
-{
- SCM um_clauses = SCM_EOL;
- SCM clause_idx;
-
- for (clause_idx = SCM_CDR (expr);
- !scm_is_null (clause_idx);
- clause_idx = SCM_CDR (clause_idx))
- {
- const SCM clause = SCM_CAR (clause_idx);
- const SCM sequence = SCM_CDR (clause);
- const SCM test = SCM_CAR (clause);
- SCM um_test;
- SCM um_sequence;
- SCM um_clause;
-
- if (scm_is_eq (test, SCM_IM_ELSE))
- um_test = scm_sym_else;
- else
- um_test = unmemoize_expression (test, env);
-
- if (!scm_is_null (sequence) && scm_is_eq (SCM_CAR (sequence),
- SCM_IM_ARROW))
- {
- const SCM target = SCM_CADR (sequence);
- const SCM um_target = unmemoize_expression (target, env);
- um_sequence = scm_list_2 (scm_sym_arrow, um_target);
- }
- else
- {
- um_sequence = unmemoize_exprs (sequence, env);
- }
-
- um_clause = scm_cons (um_test, um_sequence);
- um_clauses = scm_cons (um_clause, um_clauses);
- }
- um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
-
- return scm_cons (scm_sym_cond, um_clauses);
-}
-
-
-SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
-SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
-
-/* Guile provides an extension to R5RS' define syntax to represent function
- * currying in a compact way. With this extension, it is allowed to write
- * (define <nested-variable> <body>), where <nested-variable> has of one of
- * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
- * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
- * should be either a sequence of zero or more variables, or a sequence of one
- * or more variables followed by a space-delimited period and another
- * variable. Each level of argument nesting wraps the <body> within another
- * lambda expression. For example, the following forms are allowed, each one
- * followed by an equivalent, more explicit implementation.
- * Example 1:
- * (define ((a b . c) . d) <body>) is equivalent to
- * (define a (lambda (b . c) (lambda d <body>)))
- * Example 2:
- * (define (((a) b) c . d) <body>) is equivalent to
- * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
- */
-/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
- * module that does not implement this extension. */
-static SCM
-canonicalize_define (const SCM expr)
-{
- SCM body;
- SCM variable;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-
- body = SCM_CDR (cdr_expr);
- variable = SCM_CAR (cdr_expr);
- while (scm_is_pair (variable))
- {
- /* This while loop realizes function currying by variable nesting.
- * Variable is known to be a nested-variable. In every iteration of the
- * loop another level of lambda expression is created, starting with the
- * innermost one. Note that we don't check for duplicate formals here:
- * This will be done by the memoizer of the lambda expression. */
- const SCM formals = SCM_CDR (variable);
- const SCM tail = scm_cons (formals, body);
-
- /* Add source properties to each new lambda expression: */
- const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail);
-
- body = scm_list_1 (lambda);
- variable = SCM_CAR (variable);
- }
- ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
- ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
-
- SCM_SETCAR (cdr_expr, variable);
- SCM_SETCDR (cdr_expr, body);
- return expr;
-}
-
-/* According to Section 5.2.1 of R5RS we first have to make sure that the
- variable is bound, and then perform the `(set! variable expression)'
- operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
- bound. This means that EXPRESSION won't necessarily be able to assign
- values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
-static SCM
-scm_m_define (SCM expr, SCM env)
-{
- ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
-
- {
- const SCM canonical_definition = canonicalize_define (expr);
- const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
- const SCM variable = SCM_CAR (cdr_canonical_definition);
- const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
- const SCM location
- = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
-
- if (SCM_REC_PROCNAMES_P)
- {
- SCM tmp = value;
- while (SCM_MACROP (tmp))
- tmp = SCM_MACRO_CODE (tmp);
- if (scm_is_true (scm_procedure_p (tmp))
- /* Only the first definition determines the name. */
- && scm_is_false (scm_procedure_property (tmp, scm_sym_name)))
- scm_set_procedure_property_x (tmp, scm_sym_name, variable);
- }
-
- SCM_VARIABLE_SET (location, value);
-
- return SCM_UNSPECIFIED;
- }
-}
-
-
-/* This is a helper function for forms (<keyword> <expression>) that are
- * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
- * for easy creation of a thunk (i. e. a closure without arguments) using the
- * ('() <memoized_expression>) tail of the memoized form. */
-static SCM
-memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
-
- SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr));
-
- return expr;
-}
-
-
-SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay);
-SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
-
-/* Promises are implemented as closures with an empty parameter list. Thus,
- * (delay <expression>) is transformed into (#@delay '() <expression>), where
- * the empty list represents the empty parameter list. This representation
- * allows for easy creation of the closure during evaluation. */
-static SCM
-scm_m_delay (SCM expr, SCM env)
-{
- const SCM new_expr = memoize_as_thunk_prototype (expr, env);
- SCM_SETCAR (new_expr, SCM_IM_DELAY);
- return new_expr;
-}
-
-static SCM
-unmemoize_delay (const SCM expr, const SCM env)
-{
- const SCM thunk_expr = SCM_CADDR (expr);
- /* A promise is implemented as a closure, and when applying a
- closure the evaluator adds a new frame to the environment - even
- though, in the case of a promise, the added frame is always
- empty. We need to extend the environment here in the same way,
- so that any ILOCs in thunk_expr can be unmemoized correctly. */
- const SCM new_env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, new_env));
-}
-
-
-SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
-SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
-
-/* DO gets the most radically altered syntax. The order of the vars is
- * reversed here. During the evaluation this allows for simple consing of the
- * results of the inits and steps:
-
- (do ((<var1> <init1> <step1>)
- (<var2> <init2>)
- ... )
- (<test> <return>)
- <body>)
-
- ;; becomes
-
- (#@do (<init1> <init2> ... <initn>)
- (varn ... var2 var1)
- (<test> <return>)
- (<body>)
- <step1> <step2> ... <stepn>) ;; missing steps replaced by var
- */
-static SCM
-scm_m_do (SCM expr, SCM env SCM_UNUSED)
-{
- SCM variables = SCM_EOL;
- SCM init_forms = SCM_EOL;
- SCM step_forms = SCM_EOL;
- SCM binding_idx;
- SCM cddr_expr;
- SCM exit_clause;
- SCM commands;
- SCM tail;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-
- /* Collect variables, init and step forms. */
- binding_idx = SCM_CAR (cdr_expr);
- ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0,
- s_bad_bindings, binding_idx, expr);
- for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
- {
- const SCM binding = SCM_CAR (binding_idx);
- const long length = scm_ilength (binding);
- ASSERT_SYNTAX_2 (length == 2 || length == 3,
- s_bad_binding, binding, expr);
-
- {
- const SCM name = SCM_CAR (binding);
- const SCM init = SCM_CADR (binding);
- const SCM step = (length == 2) ? name : SCM_CADDR (binding);
- ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
- ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, variables)),
- s_duplicate_binding, name, expr);
-
- variables = scm_cons (name, variables);
- init_forms = scm_cons (init, init_forms);
- step_forms = scm_cons (step, step_forms);
- }
- }
- init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED);
- step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED);
-
- /* Memoize the test form and the exit sequence. */
- cddr_expr = SCM_CDR (cdr_expr);
- exit_clause = SCM_CAR (cddr_expr);
- ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1,
- s_bad_exit_clause, exit_clause, expr);
-
- commands = SCM_CDR (cddr_expr);
- tail = scm_cons2 (exit_clause, commands, step_forms);
- tail = scm_cons2 (init_forms, variables, tail);
- SCM_SETCAR (expr, SCM_IM_DO);
- SCM_SETCDR (expr, tail);
- return expr;
-}
-
-static SCM
-unmemoize_do (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM rnames = SCM_CAR (cddr_expr);
- const SCM extended_env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
- const SCM cdddr_expr = SCM_CDR (cddr_expr);
- const SCM exit_sequence = SCM_CAR (cdddr_expr);
- const SCM um_exit_sequence = unmemoize_exprs (exit_sequence, extended_env);
- const SCM cddddr_expr = SCM_CDR (cdddr_expr);
- const SCM um_body = unmemoize_exprs (SCM_CAR (cddddr_expr), extended_env);
-
- /* build transformed binding list */
- SCM um_names = scm_reverse (rnames);
- SCM um_inits = unmemoize_exprs (SCM_CAR (cdr_expr), env);
- SCM um_steps = unmemoize_exprs (SCM_CDR (cddddr_expr), extended_env);
- SCM um_bindings = SCM_EOL;
- while (!scm_is_null (um_names))
- {
- const SCM name = SCM_CAR (um_names);
- const SCM init = SCM_CAR (um_inits);
- SCM step = SCM_CAR (um_steps);
- step = scm_is_eq (step, name) ? SCM_EOL : scm_list_1 (step);
-
- um_bindings = scm_cons (scm_cons2 (name, init, step), um_bindings);
-
- um_names = SCM_CDR (um_names);
- um_inits = SCM_CDR (um_inits);
- um_steps = SCM_CDR (um_steps);
- }
- um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
-
- return scm_cons (scm_sym_do,
- scm_cons2 (um_bindings, um_exit_sequence, um_body));
-}
-
-
-SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
-SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
-
-static SCM
-scm_m_if (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
- ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
- SCM_SETCAR (expr, SCM_IM_IF);
- return expr;
-}
-
-static SCM
-unmemoize_if (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM um_condition = unmemoize_expression (SCM_CAR (cdr_expr), env);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM um_then = unmemoize_expression (SCM_CAR (cddr_expr), env);
- const SCM cdddr_expr = SCM_CDR (cddr_expr);
-
- if (scm_is_null (cdddr_expr))
- {
- return scm_list_3 (scm_sym_if, um_condition, um_then);
- }
- else
- {
- const SCM um_else = unmemoize_expression (SCM_CAR (cdddr_expr), env);
- return scm_list_4 (scm_sym_if, um_condition, um_then, um_else);
- }
-}
-
-
-SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
-SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
-
-/* A helper function for memoize_lambda to support checking for duplicate
- * formal arguments: Return true if OBJ is `eq?' to one of the elements of
- * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
- * forms that a formal argument can have:
- * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
-static int
-c_improper_memq (SCM obj, SCM list)
-{
- for (; scm_is_pair (list); list = SCM_CDR (list))
- {
- if (scm_is_eq (SCM_CAR (list), obj))
- return 1;
- }
- return scm_is_eq (list, obj);
-}
-
-static SCM
-scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
-{
- SCM formals;
- SCM formals_idx;
- SCM cddr_expr;
- int documentation;
- SCM body;
- SCM new_body;
-
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
-
- /* Before iterating the list of formal arguments, make sure the formals
- * actually are given as either a symbol or a non-cyclic list. */
- formals = SCM_CAR (cdr_expr);
- if (scm_is_pair (formals))
- {
- /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
- * detected, report a 'Bad formals' error. */
- }
- else
- {
- ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
- s_bad_formals, formals, expr);
- }
-
- /* Now iterate the list of formal arguments to check if all formals are
- * symbols, and that there are no duplicates. */
- formals_idx = formals;
- while (scm_is_pair (formals_idx))
- {
- const SCM formal = SCM_CAR (formals_idx);
- const SCM next_idx = SCM_CDR (formals_idx);
- ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
- ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
- s_duplicate_formal, formal, expr);
- formals_idx = next_idx;
- }
- ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
- s_bad_formal, formals_idx, expr);
-
- /* Memoize the body. Keep a potential documentation string. */
- /* Dirk:FIXME:: We should probably extract the documentation string to
- * some external database. Otherwise it will slow down execution, since
- * the documentation string will have to be skipped with every execution
- * of the closure. */
- cddr_expr = SCM_CDR (cdr_expr);
- documentation = (length >= 3 && scm_is_string (SCM_CAR (cddr_expr)));
- body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
- new_body = m_body (SCM_IM_LAMBDA, body);
-
- SCM_SETCAR (expr, SCM_IM_LAMBDA);
- if (documentation)
- SCM_SETCDR (cddr_expr, new_body);
- else
- SCM_SETCDR (cdr_expr, new_body);
- return expr;
-}
-
-static SCM
-unmemoize_lambda (const SCM expr, const SCM env)
-{
- const SCM formals = SCM_CADR (expr);
- const SCM body = SCM_CDDR (expr);
-
- const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env);
- const SCM um_formals = scm_i_finite_list_copy (formals);
- const SCM um_body = unmemoize_exprs (body, new_env);
-
- return scm_cons2 (scm_sym_lambda, um_formals, um_body);
-}
-
-
-/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
-static void
-check_bindings (const SCM bindings, const SCM expr)
-{
- SCM binding_idx;
-
- ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
- s_bad_bindings, bindings, expr);
-
- binding_idx = bindings;
- for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
- {
- SCM name; /* const */
-
- const SCM binding = SCM_CAR (binding_idx);
- ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
- s_bad_binding, binding, expr);
-
- name = SCM_CAR (binding);
- ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
- }
-}
-
-
-/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
- * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
- * variables are returned in a list with their order reversed, and the init
- * forms are returned in a list in the same order as they are given in the
- * bindings. If a duplicate variable name is detected, an error is
- * signalled. */
-static void
-transform_bindings (
- const SCM bindings, const SCM expr,
- SCM *const rvarptr, SCM *const initptr )
-{
- SCM rvariables = SCM_EOL;
- SCM rinits = SCM_EOL;
- SCM binding_idx = bindings;
- for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
- {
- const SCM binding = SCM_CAR (binding_idx);
- const SCM cdr_binding = SCM_CDR (binding);
- const SCM name = SCM_CAR (binding);
- ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
- s_duplicate_binding, name, expr);
- rvariables = scm_cons (name, rvariables);
- rinits = scm_cons (SCM_CAR (cdr_binding), rinits);
- }
- *rvarptr = rvariables;
- *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
-}
-
-
-SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
-SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
-
-/* This function is a helper function for memoize_let. It transforms
- * (let name ((var init) ...) body ...) into
- * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
- * and memoizes the expression. It is assumed that the caller has checked
- * that name is a symbol and that there are bindings and a body. */
-static SCM
-memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
-{
- SCM rvariables;
- SCM variables;
- SCM inits;
-
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM name = SCM_CAR (cdr_expr);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM bindings = SCM_CAR (cddr_expr);
- check_bindings (bindings, expr);
-
- transform_bindings (bindings, expr, &rvariables, &inits);
- variables = scm_reverse_x (rvariables, SCM_UNDEFINED);
-
- {
- const SCM let_body = SCM_CDR (cddr_expr);
- const SCM lambda_body = m_body (SCM_IM_LET, let_body);
- const SCM lambda_tail = scm_cons (variables, lambda_body);
- const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);
-
- const SCM rvar = scm_list_1 (name);
- const SCM init = scm_list_1 (lambda_form);
- const SCM body = m_body (SCM_IM_LET, scm_list_1 (name));
- const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
- const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
- return scm_cons_source (expr, letrec_form, inits);
- }
-}
-
-/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
- * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
-static SCM
-scm_m_let (SCM expr, SCM env)
-{
- SCM bindings;
-
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
-
- bindings = SCM_CAR (cdr_expr);
- if (scm_is_symbol (bindings))
- {
- ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
- return memoize_named_let (expr, env);
- }
-
- check_bindings (bindings, expr);
- if (scm_is_null (bindings) || scm_is_null (SCM_CDR (bindings)))
- {
- /* Special case: no bindings or single binding => let* is faster. */
- const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
- return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
- }
- else
- {
- /* plain let */
- SCM rvariables;
- SCM inits;
- transform_bindings (bindings, expr, &rvariables, &inits);
-
- {
- const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
- const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
- SCM_SETCAR (expr, SCM_IM_LET);
- SCM_SETCDR (expr, new_tail);
- return expr;
- }
- }
-}
-
-static SCM
-build_binding_list (SCM rnames, SCM rinits)
-{
- SCM bindings = SCM_EOL;
- while (!scm_is_null (rnames))
- {
- const SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
- bindings = scm_cons (binding, bindings);
- rnames = SCM_CDR (rnames);
- rinits = SCM_CDR (rinits);
- }
- return bindings;
-}
-
-static SCM
-unmemoize_let (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM um_rnames = SCM_CAR (cdr_expr);
- const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), env);
- const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
- const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
- const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
-
- return scm_cons2 (scm_sym_let, um_bindings, um_body);
-}
-
-
-SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
-SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
-
-static SCM
-scm_m_letrec (SCM expr, SCM env)
-{
- SCM bindings;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-
- bindings = SCM_CAR (cdr_expr);
- if (scm_is_null (bindings))
- {
- /* no bindings, let* is executed faster */
- SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
- return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
- }
- else
- {
- SCM rvariables;
- SCM inits;
- SCM new_body;
-
- check_bindings (bindings, expr);
- transform_bindings (bindings, expr, &rvariables, &inits);
- new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
- return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
- }
-}
-
-static SCM
-unmemoize_letrec (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM um_rnames = SCM_CAR (cdr_expr);
- const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), extended_env);
- const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
- const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
- const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
-
- return scm_cons2 (scm_sym_letrec, um_bindings, um_body);
-}
-
-
-
-SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
-SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
-
-/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
- * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
-static SCM
-scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
-{
- SCM binding_idx;
- SCM new_body;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-
- binding_idx = SCM_CAR (cdr_expr);
- check_bindings (binding_idx, expr);
-
- /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
- * transformation is done in place. At the beginning of one iteration of
- * the loop the variable binding_idx holds the form
- * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
- * where P1, P2 and P3 indicate the pairs, that are relevant for the
- * transformation. P1 and P2 are modified in the loop, P3 remains
- * untouched. After the execution of the loop, P1 will hold
- * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
- * and binding_idx will hold P3. */
- while (!scm_is_null (binding_idx))
- {
- const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */
- const SCM binding = SCM_CAR (binding_idx);
- const SCM name = SCM_CAR (binding);
- const SCM cdr_binding = SCM_CDR (binding);
-
- SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */
- SCM_SETCAR (binding_idx, name); /* update P1 */
- SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */
-
- binding_idx = cdr_binding_idx; /* continue with P3 */
- }
-
- new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
- SCM_SETCAR (expr, SCM_IM_LETSTAR);
- /* the bindings have been changed in place */
- SCM_SETCDR (cdr_expr, new_body);
- return expr;
-}
-
-static SCM
-unmemoize_letstar (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM body = SCM_CDR (cdr_expr);
- SCM bindings = SCM_CAR (cdr_expr);
- SCM um_bindings = SCM_EOL;
- SCM extended_env = env;
- SCM um_body;
-
- while (!scm_is_null (bindings))
- {
- const SCM variable = SCM_CAR (bindings);
- const SCM init = SCM_CADR (bindings);
- const SCM um_init = unmemoize_expression (init, extended_env);
- um_bindings = scm_cons (scm_list_2 (variable, um_init), um_bindings);
- extended_env = SCM_EXTEND_ENV (variable, SCM_BOOL_F, extended_env);
- bindings = SCM_CDDR (bindings);
- }
- um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
-
- um_body = unmemoize_exprs (body, extended_env);
-
- return scm_cons2 (scm_sym_letstar, um_bindings, um_body);
-}
-
-
-SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
-SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
-
-static SCM
-scm_m_or (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
-
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
-
- if (length == 0)
- {
- /* Special case: (or) is replaced by #f. */
- return SCM_BOOL_F;
- }
- else
- {
- SCM_SETCAR (expr, SCM_IM_OR);
- return expr;
- }
-}
-
-static SCM
-unmemoize_or (const SCM expr, const SCM env)
-{
- return scm_cons (scm_sym_or, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
-SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
-SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
-SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
-
-/* Internal function to handle a quasiquotation: 'form' is the parameter in
- * the call (quasiquotation form), 'env' is the environment where unquoted
- * expressions will be evaluated, and 'depth' is the current quasiquotation
- * nesting level and is known to be greater than zero. */
-static SCM
-iqq (SCM form, SCM env, unsigned long int depth)
-{
- if (scm_is_pair (form))
- {
- const SCM tmp = SCM_CAR (form);
- if (scm_is_eq (tmp, scm_sym_quasiquote))
- {
- const SCM args = SCM_CDR (form);
- ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
- return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
- }
- else if (scm_is_eq (tmp, scm_sym_unquote))
- {
- const SCM args = SCM_CDR (form);
- ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
- if (depth - 1 == 0)
- return scm_eval_car (args, env);
- else
- return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
- }
- else if (scm_is_pair (tmp)
- && scm_is_eq (SCM_CAR (tmp), scm_sym_uq_splicing))
- {
- const SCM args = SCM_CDR (tmp);
- ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
- if (depth - 1 == 0)
- {
- const SCM list = scm_eval_car (args, env);
- const SCM rest = SCM_CDR (form);
- ASSERT_SYNTAX_2 (scm_ilength (list) >= 0,
- s_splicing, list, form);
- return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
- }
- else
- return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
- iqq (SCM_CDR (form), env, depth));
- }
- else
- return scm_cons (iqq (SCM_CAR (form), env, depth),
- iqq (SCM_CDR (form), env, depth));
- }
- else if (scm_is_vector (form))
- return scm_vector (iqq (scm_vector_to_list (form), env, depth));
- else
- return form;
-}
-
-static SCM
-scm_m_quasiquote (SCM expr, SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
- return iqq (SCM_CAR (cdr_expr), env, 1);
-}
-
-
-SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
-
-static SCM
-scm_m_quote (SCM expr, SCM env SCM_UNUSED)
-{
- SCM quotee;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
- quotee = SCM_CAR (cdr_expr);
- if (is_self_quoting_p (quotee))
- return quotee;
-
- SCM_SETCAR (expr, SCM_IM_QUOTE);
- SCM_SETCDR (expr, quotee);
- return expr;
-}
-
-static SCM
-unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED)
-{
- return scm_list_2 (scm_sym_quote, SCM_CDR (expr));
-}
-
-
-/* Will go into the RnRS module when Guile is factorized.
-SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
-static const char s_set_x[] = "set!";
-SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
-
-static SCM
-scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
-{
- SCM variable;
- SCM new_variable;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
- variable = SCM_CAR (cdr_expr);
-
- /* Memoize the variable form. */
- ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
- new_variable = lookup_symbol (variable, env);
- /* Leave the memoization of unbound symbols to lazy memoization: */
- if (SCM_UNBNDP (new_variable))
- new_variable = variable;
-
- SCM_SETCAR (expr, SCM_IM_SET_X);
- SCM_SETCAR (cdr_expr, new_variable);
- return expr;
-}
-
-static SCM
-unmemoize_set_x (const SCM expr, const SCM env)
-{
- return scm_cons (scm_sym_set_x, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-\f
-/* Start of the memoizers for non-R5RS builtin macros. */
-
-
-SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at);
-SCM_GLOBAL_SYMBOL (scm_sym_at, s_at);
-
-static SCM
-scm_m_at (SCM expr, SCM env SCM_UNUSED)
-{
- SCM mod, var;
- ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr);
-
- mod = scm_resolve_module (scm_cadr (expr));
- if (scm_is_false (mod))
- error_unbound_variable (expr);
- var = scm_module_variable (scm_module_public_interface (mod), scm_caddr (expr));
- if (scm_is_false (var))
- error_unbound_variable (expr);
-
- return var;
-}
-
-SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat);
-SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat);
-
-static SCM
-scm_m_atat (SCM expr, SCM env SCM_UNUSED)
-{
- SCM mod, var;
- ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr);
-
- mod = scm_resolve_module (scm_cadr (expr));
- if (scm_is_false (mod))
- error_unbound_variable (expr);
- var = scm_module_variable (mod, scm_caddr (expr));
- if (scm_is_false (var))
- error_unbound_variable (expr);
-
- return var;
-}
-
-SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
-SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
-SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
-
-static SCM
-scm_m_apply (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_APPLY);
- return expr;
-}
-
-static SCM
-unmemoize_apply (const SCM expr, const SCM env)
-{
- return scm_list_2 (scm_sym_atapply, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
-
-/* FIXME: The following explanation should go into the documentation: */
-/* (@bind ((var init) ...) body ...) will assign the values of the `init's to
- * the global variables named by `var's (symbols, not evaluated), creating
- * them if they don't exist, executes body, and then restores the previous
- * values of the `var's. Additionally, whenever control leaves body, the
- * values of the `var's are saved and restored when control returns. It is an
- * error when a symbol appears more than once among the `var's. All `init's
- * are evaluated before any `var' is set.
- *
- * Think of this as `let' for dynamic scope.
- */
-
-/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
- * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
- *
- * FIXME - also implement `@bind*'.
- */
-static SCM
-scm_m_atbind (SCM expr, SCM env)
-{
- SCM bindings;
- SCM rvariables;
- SCM inits;
- SCM variable_idx;
-
- const SCM top_level = scm_env_top_level (env);
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
- bindings = SCM_CAR (cdr_expr);
- check_bindings (bindings, expr);
- transform_bindings (bindings, expr, &rvariables, &inits);
-
- for (variable_idx = rvariables;
- !scm_is_null (variable_idx);
- variable_idx = SCM_CDR (variable_idx))
- {
- /* The first call to scm_sym2var will look beyond the current module,
- * while the second call wont. */
- const SCM variable = SCM_CAR (variable_idx);
- SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F);
- if (scm_is_false (new_variable))
- new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T);
- SCM_SETCAR (variable_idx, new_variable);
- }
-
- SCM_SETCAR (expr, SCM_IM_BIND);
- SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits));
- return expr;
-}
-
-
-SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
-SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
-
-static SCM
-scm_m_cont (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_CONT);
- return expr;
-}
-
-static SCM
-unmemoize_atcall_cc (const SCM expr, const SCM env)
-{
- return scm_list_2 (scm_sym_atcall_cc, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
-SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
-
-static SCM
-scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
- return expr;
-}
-
-static SCM
-unmemoize_at_call_with_values (const SCM expr, const SCM env)
-{
- return scm_list_2 (scm_sym_at_call_with_values,
- unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
-SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when);
-SCM_SYMBOL (sym_eval, "eval");
-SCM_SYMBOL (sym_load, "load");
-
-
-static SCM
-scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
-{
- ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
-
- if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr)))
- || scm_is_true (scm_memq (sym_load, scm_cadr (expr))))
- return scm_cons (SCM_IM_BEGIN, scm_cddr (expr));
-
- return scm_list_1 (SCM_IM_BEGIN);
-}
-
-#if 0
-
-/* See futures.h for a comment why futures are not enabled.
- */
-
-SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future);
-SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
-
-/* Like promises, futures are implemented as closures with an empty
- * parameter list. Thus, (future <expression>) is transformed into
- * (#@future '() <expression>), where the empty list represents the
- * empty parameter list. This representation allows for easy creation
- * of the closure during evaluation. */
-static SCM
-scm_m_future (SCM expr, SCM env)
-{
- const SCM new_expr = memoize_as_thunk_prototype (expr, env);
- SCM_SETCAR (new_expr, SCM_IM_FUTURE);
- return new_expr;
-}
-
-static SCM
-unmemoize_future (const SCM expr, const SCM env)
-{
- const SCM thunk_expr = SCM_CADDR (expr);
- return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env));
-}
-
-#endif /* futures disabled. */
-
-SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
-SCM_SYMBOL (scm_sym_setter, "setter");
-
-static SCM
-scm_m_generalized_set_x (SCM expr, SCM env)
-{
- SCM target, exp_target;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
-
- target = SCM_CAR (cdr_expr);
- if (!scm_is_pair (target))
- {
- /* R5RS usage */
- return scm_m_set_x (expr, env);
- }
- else
- {
- /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
- /* Macroexpanding the target might return things of the form
- (begin <atom>). In that case, <atom> must be a symbol or a
- variable and we memoize to (set! <atom> ...).
- */
- exp_target = macroexp (target, env);
- if (scm_is_eq (SCM_CAR (exp_target), SCM_IM_BEGIN)
- && !scm_is_null (SCM_CDR (exp_target))
- && scm_is_null (SCM_CDDR (exp_target)))
- {
- exp_target= SCM_CADR (exp_target);
- ASSERT_SYNTAX_2 (scm_is_symbol (exp_target)
- || SCM_VARIABLEP (exp_target),
- s_bad_variable, exp_target, expr);
- return scm_cons (SCM_IM_SET_X, scm_cons (exp_target,
- SCM_CDR (cdr_expr)));
- }
- else
- {
- const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target));
- const SCM setter_proc = scm_cons_source (expr, scm_sym_setter,
- setter_proc_tail);
-
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target),
- cddr_expr));
-
- SCM_SETCAR (expr, setter_proc);
- SCM_SETCDR (expr, setter_args);
- return expr;
- }
- }
-}
-
-
-/* @slot-ref is bound privately in the (oop goops) module from goops.c. As
- * soon as the module system allows us to more freely create bindings in
- * arbitrary modules during the startup phase, the code from goops.c should be
- * moved here. */
-
-SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
-SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
-SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
-
-static SCM
-scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
-{
- SCM slot_nr;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
- slot_nr = SCM_CADR (cdr_expr);
- ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
-
- SCM_SETCAR (expr, SCM_IM_SLOT_REF);
- SCM_SETCDR (cdr_expr, slot_nr);
- return expr;
-}
-
-static SCM
-unmemoize_atslot_ref (const SCM expr, const SCM env)
-{
- const SCM instance = SCM_CADR (expr);
- const SCM um_instance = unmemoize_expression (instance, env);
- const SCM slot_nr = SCM_CDDR (expr);
- return scm_list_3 (sym_atslot_ref, um_instance, slot_nr);
-}
-
-
-/* @slot-set! is bound privately in the (oop goops) module from goops.c. As
- * soon as the module system allows us to more freely create bindings in
- * arbitrary modules during the startup phase, the code from goops.c should be
- * moved here. */
-
-SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
-
-static SCM
-scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
-{
- SCM slot_nr;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr);
- slot_nr = SCM_CADR (cdr_expr);
- ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
-
- SCM_SETCAR (expr, SCM_IM_SLOT_SET_X);
- return expr;
-}
-
-static SCM
-unmemoize_atslot_set_x (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM instance = SCM_CAR (cdr_expr);
- const SCM um_instance = unmemoize_expression (instance, env);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM slot_nr = SCM_CAR (cddr_expr);
- const SCM cdddr_expr = SCM_CDR (cddr_expr);
- const SCM value = SCM_CAR (cdddr_expr);
- const SCM um_value = unmemoize_expression (value, env);
- return scm_list_4 (sym_atslot_set_x, um_instance, slot_nr, um_value);
-}
-
-
-#if SCM_ENABLE_ELISP
-
-static const char s_defun[] = "Symbol's function definition is void";
-
-SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
-
-/* nil-cond expressions have the form
- * (nil-cond COND VAL COND VAL ... ELSEVAL) */
-static SCM
-scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
-{
- const long length = scm_ilength (SCM_CDR (expr));
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_NIL_COND);
- return expr;
-}
-
-
-SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
-
-/* The @fop-macro handles procedure and macro applications for elisp. The
- * input expression must have the form
- * (@fop <var> (transformer-macro <expr> ...))
- * where <var> must be a symbol. The expression is transformed into the
- * memoized form of either
- * (apply <un-aliased var> (transformer-macro <expr> ...))
- * if the value of var (across all aliasing) is not a macro, or
- * (<un-aliased var> <expr> ...)
- * if var is a macro. */
-static SCM
-scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
-{
- SCM location;
- SCM symbol;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr);
-
- symbol = SCM_CAR (cdr_expr);
- ASSERT_SYNTAX_2 (scm_is_symbol (symbol), s_bad_variable, symbol, expr);
-
- location = scm_symbol_fref (symbol);
- ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
-
- /* The elisp function `defalias' allows to define aliases for symbols. To
- * look up such definitions, the chain of symbol definitions has to be
- * followed up to the terminal symbol. */
- while (scm_is_symbol (SCM_VARIABLE_REF (location)))
- {
- const SCM alias = SCM_VARIABLE_REF (location);
- location = scm_symbol_fref (alias);
- ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
- }
-
- /* Memoize the value location belonging to the terminal symbol. */
- SCM_SETCAR (cdr_expr, location);
-
- if (!SCM_MACROP (SCM_VARIABLE_REF (location)))
- {
- /* Since the location does not contain a macro, the form is a procedure
- * application. Replace `@fop' by `@apply' and transform the expression
- * including the `transformer-macro'. */
- SCM_SETCAR (expr, SCM_IM_APPLY);
- return expr;
- }
- else
- {
- /* Since the location contains a macro, the arguments should not be
- * transformed, so the `transformer-macro' is cut out. The resulting
- * expression starts with the memoized variable, that is at the cdr of
- * the input expression. */
- SCM_SETCDR (cdr_expr, SCM_CDADR (cdr_expr));
- return cdr_expr;
- }
-}
-
-#endif /* SCM_ENABLE_ELISP */
-
-
-static SCM
-unmemoize_builtin_macro (const SCM expr, const SCM env)
-{
- switch (ISYMNUM (SCM_CAR (expr)))
- {
- case (ISYMNUM (SCM_IM_AND)):
- return unmemoize_and (expr, env);
-
- case (ISYMNUM (SCM_IM_BEGIN)):
- return unmemoize_begin (expr, env);
-
- case (ISYMNUM (SCM_IM_CASE)):
- return unmemoize_case (expr, env);
-
- case (ISYMNUM (SCM_IM_COND)):
- return unmemoize_cond (expr, env);
-
- case (ISYMNUM (SCM_IM_DELAY)):
- return unmemoize_delay (expr, env);
-
- case (ISYMNUM (SCM_IM_DO)):
- return unmemoize_do (expr, env);
-
- case (ISYMNUM (SCM_IM_IF)):
- return unmemoize_if (expr, env);
-
- case (ISYMNUM (SCM_IM_LAMBDA)):
- return unmemoize_lambda (expr, env);
-
- case (ISYMNUM (SCM_IM_LET)):
- return unmemoize_let (expr, env);
-
- case (ISYMNUM (SCM_IM_LETREC)):
- return unmemoize_letrec (expr, env);
-
- case (ISYMNUM (SCM_IM_LETSTAR)):
- return unmemoize_letstar (expr, env);
-
- case (ISYMNUM (SCM_IM_OR)):
- return unmemoize_or (expr, env);
-
- case (ISYMNUM (SCM_IM_QUOTE)):
- return unmemoize_quote (expr, env);
-
- case (ISYMNUM (SCM_IM_SET_X)):
- return unmemoize_set_x (expr, env);
-
- case (ISYMNUM (SCM_IM_APPLY)):
- return unmemoize_apply (expr, env);
-
- case (ISYMNUM (SCM_IM_BIND)):
- return unmemoize_exprs (expr, env); /* FIXME */
-
- case (ISYMNUM (SCM_IM_CONT)):
- return unmemoize_atcall_cc (expr, env);
-
- case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
- return unmemoize_at_call_with_values (expr, env);
-
-#if 0
- /* See futures.h for a comment why futures are not enabled.
- */
- case (ISYMNUM (SCM_IM_FUTURE)):
- return unmemoize_future (expr, env);
-#endif
-
- case (ISYMNUM (SCM_IM_SLOT_REF)):
- return unmemoize_atslot_ref (expr, env);
-
- case (ISYMNUM (SCM_IM_SLOT_SET_X)):
- return unmemoize_atslot_set_x (expr, env);
-
- case (ISYMNUM (SCM_IM_NIL_COND)):
- return unmemoize_exprs (expr, env); /* FIXME */
-
- default:
- return unmemoize_exprs (expr, env); /* FIXME */
- }
-}
-
-
-/* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
- * respectively a memoized body together with its environment and rewrite it
- * to its original form. Thus, these functions are the inversion of the
- * rewrite rules above. The procedure is not optimized for speed. It's used
- * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
- *
- * Unmemoizing is not a reliable process. You cannot in general expect to get
- * the original source back.
- *
- * However, GOOPS currently relies on this for method compilation. This ought
- * to change. */
-
-SCM
-scm_i_unmemocopy_expr (SCM expr, SCM env)
-{
- const SCM source_properties = scm_whash_lookup (scm_source_whash, expr);
- const SCM um_expr = unmemoize_expression (expr, env);
-
- if (scm_is_true (source_properties))
- scm_whash_insert (scm_source_whash, um_expr, source_properties);
-
- return um_expr;
-}
-
-SCM
-scm_i_unmemocopy_body (SCM forms, SCM env)
-{
- const SCM source_properties = scm_whash_lookup (scm_source_whash, forms);
- const SCM um_forms = unmemoize_exprs (forms, env);
-
- if (scm_is_true (source_properties))
- scm_whash_insert (scm_source_whash, um_forms, source_properties);
-
- return um_forms;
-}
-
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-static SCM scm_m_undefine (SCM expr, SCM env);
-
-SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
-
-static SCM
-scm_m_undefine (SCM expr, SCM env)
-{
- SCM variable;
- SCM location;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (SCM_TOP_LEVEL (env), "Bad undefine placement in", expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
-
- scm_c_issue_deprecation_warning
- ("`undefine' is deprecated.\n");
-
- variable = SCM_CAR (cdr_expr);
- ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
- location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F);
- ASSERT_SYNTAX_2 (scm_is_true (location)
- && !SCM_UNBNDP (SCM_VARIABLE_REF (location)),
- "variable already unbound ", variable, expr);
- SCM_VARIABLE_SET (location, SCM_UNDEFINED);
- return SCM_UNSPECIFIED;
-}
-
-#endif /* SCM_ENABLE_DEPRECATED */
-
-
-\f
-/*****************************************************************************/
-/*****************************************************************************/
-/* The definitions for execution start here. */
-/*****************************************************************************/
-/*****************************************************************************/
-
-SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");
-SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
-SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
-SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol, "memoize-symbol");
-SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
-SCM_SYMBOL (sym_instead, "instead");
-
-/* A function object to implement "apply" for non-closure functions. */
-static SCM f_apply;
-/* An endless list consisting of #<undefined> objects: */
-static SCM undefineds;
-
-
-int
-scm_badargsp (SCM formals, SCM args)
-{
- while (!scm_is_null (formals))
- {
- if (!scm_is_pair (formals))
- return 0;
- if (scm_is_null (args))
- return 1;
- formals = SCM_CDR (formals);
- args = SCM_CDR (args);
- }
- return !scm_is_null (args) ? 1 : 0;
-}
-
-\f
-
-/* The evaluator contains a plethora of EVAL symbols.
- *
- *
- * SCM_I_EVALIM is used when it is known that the expression is an
- * immediate. (This macro never calls an evaluator.)
- *
- * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
- * memoized. Expressions that are not of the form '(<form> <form> ...)' are
- * evaluated inline without calling an evaluator.
- *
- * This macro uses ceval or deval depending on its 3rd argument.
- *
- * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
- * potentially replacing a symbol at the position Y:<form> by its memoized
- * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
- * evaluation is performed inline without calling an evaluator.
- *
- * This macro uses ceval or deval depending on its 3rd argument.
- *
- */
-
-#define SCM_I_EVALIM2(x) \
- ((scm_is_eq ((x), SCM_EOL) \
- ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
- : 0), \
- (x))
-
-#define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
- ? *scm_ilookup ((x), (env)) \
- : SCM_I_EVALIM2(x))
-
-#define SCM_I_XEVAL(x, env, debug_p) \
- (SCM_IMP (x) \
- ? SCM_I_EVALIM2 (x) \
- : (SCM_VARIABLEP (x) \
- ? SCM_VARIABLE_REF (x) \
- : (scm_is_pair (x) \
- ? (debug_p \
- ? deval ((x), (env)) \
- : ceval ((x), (env))) \
- : (x))))
-
-#define SCM_I_XEVALCAR(x, env, debug_p) \
- (SCM_IMP (SCM_CAR (x)) \
- ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
- : (SCM_VARIABLEP (SCM_CAR (x)) \
- ? SCM_VARIABLE_REF (SCM_CAR (x)) \
- : (scm_is_pair (SCM_CAR (x)) \
- ? (debug_p \
- ? deval (SCM_CAR (x), (env)) \
- : ceval (SCM_CAR (x), (env))) \
- : (!scm_is_symbol (SCM_CAR (x)) \
- ? SCM_CAR (x) \
- : *scm_lookupcar ((x), (env), 1)))))
-
-scm_i_pthread_mutex_t source_mutex;
-
-
-/* Lookup a given local variable in an environment. The local variable is
- * given as an iloc, that is a triple <frame, binding, last?>, where frame
- * indicates the relative number of the environment frame (counting upwards
- * from the innermost environment frame), binding indicates the number of the
- * binding within the frame, and last? (which is extracted from the iloc using
- * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
- * very end of the improper list of bindings. */
-SCM *
-scm_ilookup (SCM iloc, SCM env)
-{
- unsigned int frame_nr = SCM_IFRAME (iloc);
- unsigned int binding_nr = SCM_IDIST (iloc);
- SCM frames = env;
- SCM bindings;
-
- for (; 0 != frame_nr; --frame_nr)
- frames = SCM_CDR (frames);
-
- bindings = SCM_CAR (frames);
- for (; 0 != binding_nr; --binding_nr)
- bindings = SCM_CDR (bindings);
-
- if (SCM_ICDRP (iloc))
- return SCM_CDRLOC (bindings);
- return SCM_CARLOC (SCM_CDR (bindings));
-}
-
-
-SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-
-/* Call this for variables that are unfound.
- */
-static void
-error_unbound_variable (SCM symbol)
-{
- scm_error (scm_unbound_variable_key, NULL,
- "Unbound variable: ~S",
- scm_list_1 (symbol), SCM_BOOL_F);
-}
-
-/* Call this for variables that are found but contain SCM_UNDEFINED.
- */
-static void
-error_defined_variable (SCM symbol)
-{
- /* We use the 'unbound-variable' key here as well, since it
- basically is the same kind of error, with a slight variation in
- the displayed message.
- */
- scm_error (scm_unbound_variable_key, NULL,
- "Variable used before given a value: ~S",
- scm_list_1 (symbol), SCM_BOOL_F);
-}
-
-
-/* The Lookup Car Race
- - by Eva Luator
-
- Memoization of variables and special forms is done while executing
- the code for the first time. As long as there is only one thread
- everything is fine, but as soon as two threads execute the same
- code concurrently `for the first time' they can come into conflict.
-
- This memoization includes rewriting variable references into more
- efficient forms and expanding macros. Furthermore, macro expansion
- includes `compiling' special forms like `let', `cond', etc. into
- tree-code instructions.
-
- There shouldn't normally be a problem with memoizing local and
- global variable references (into ilocs and variables), because all
- threads will mutate the code in *exactly* the same way and (if I
- read the C code correctly) it is not possible to observe a half-way
- mutated cons cell. The lookup procedure can handle this
- transparently without any critical sections.
-
- It is different with macro expansion, because macro expansion
- happens outside of the lookup procedure and can't be
- undone. Therefore the lookup procedure can't cope with it. It has
- to indicate failure when it detects a lost race and hope that the
- caller can handle it. Luckily, it turns out that this is the case.
-
- An example to illustrate this: Suppose that the following form will
- be memoized concurrently by two threads
-
- (let ((x 12)) x)
-
- Let's first examine the lookup of X in the body. The first thread
- decides that it has to find the symbol "x" in the environment and
- starts to scan it. Then the other thread takes over and actually
- overtakes the first. It looks up "x" and substitutes an
- appropriate iloc for it. Now the first thread continues and
- completes its lookup. It comes to exactly the same conclusions as
- the second one and could - without much ado - just overwrite the
- iloc with the same iloc.
-
- But let's see what will happen when the race occurs while looking
- up the symbol "let" at the start of the form. It could happen that
- the second thread interrupts the lookup of the first thread and not
- only substitutes a variable for it but goes right ahead and
- replaces it with the compiled form (#@let* (x 12) x). Now, when
- the first thread completes its lookup, it would replace the #@let*
- with a variable containing the "let" binding, effectively reverting
- the form to (let (x 12) x). This is wrong. It has to detect that
- it has lost the race and the evaluator has to reconsider the
- changed form completely.
-
- This race condition could be resolved with some kind of traffic
- light (like mutexes) around scm_lookupcar, but I think that it is
- best to avoid them in this case. They would serialize memoization
- completely and because lookup involves calling arbitrary Scheme
- code (via the lookup-thunk), threads could be blocked for an
- arbitrary amount of time or even deadlock. But with the current
- solution a lot of unnecessary work is potentially done. */
-
-/* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
- return NULL to indicate a failed lookup due to some race conditions
- between threads. This only happens when VLOC is the first cell of
- a special form that will eventually be memoized (like `let', etc.)
- In that case the whole lookup is bogus and the caller has to
- reconsider the complete special form.
-
- SCM_LOOKUPCAR is still there, of course. It just calls
- SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
- should only be called when it is known that VLOC is not the first
- pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
- for NULL. I think I've found the only places where this
- applies. */
-
-static SCM *
-scm_lookupcar1 (SCM vloc, SCM genv, int check)
-{
- SCM env = genv;
- register SCM *al, fl, var = SCM_CAR (vloc);
- register SCM iloc = SCM_ILOC00;
- for (; SCM_NIMP (env); env = SCM_CDR (env))
- {
- if (!scm_is_pair (SCM_CAR (env)))
- break;
- al = SCM_CARLOC (env);
- for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
- {
- if (!scm_is_pair (fl))
- {
- if (scm_is_eq (fl, var))
- {
- if (!scm_is_eq (SCM_CAR (vloc), var))
- goto race;
- SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR);
- return SCM_CDRLOC (*al);
- }
- else
- break;
- }
- al = SCM_CDRLOC (*al);
- if (scm_is_eq (SCM_CAR (fl), var))
- {
- if (SCM_UNBNDP (SCM_CAR (*al)))
- error_defined_variable (var);
- if (!scm_is_eq (SCM_CAR (vloc), var))
- goto race;
- SCM_SETCAR (vloc, iloc);
- return SCM_CARLOC (*al);
- }
- iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC);
- }
- iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC));
- }
- {
- SCM top_thunk, real_var;
- if (SCM_NIMP (env))
- {
- top_thunk = SCM_CAR (env); /* env now refers to a
- top level env thunk */
- env = SCM_CDR (env);
- }
- else
- top_thunk = SCM_BOOL_F;
- real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F);
- if (scm_is_false (real_var))
- goto errout;
-
- if (!scm_is_null (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
- {
- errout:
- if (check)
- {
- if (scm_is_null (env))
- error_unbound_variable (var);
- else
- scm_misc_error (NULL, "Damaged environment: ~S",
- scm_list_1 (var));
- }
- else
- {
- /* A variable could not be found, but we shall
- not throw an error. */
- static SCM undef_object = SCM_UNDEFINED;
- return &undef_object;
- }
- }
-
- if (!scm_is_eq (SCM_CAR (vloc), var))
- {
- /* Some other thread has changed the very cell we are working
- on. In effect, it must have done our job or messed it up
- completely. */
- race:
- var = SCM_CAR (vloc);
- if (SCM_VARIABLEP (var))
- return SCM_VARIABLE_LOC (var);
- if (SCM_ILOCP (var))
- return scm_ilookup (var, genv);
- /* We can't cope with anything else than variables and ilocs. When
- a special form has been memoized (i.e. `let' into `#@let') we
- return NULL and expect the calling function to do the right
- thing. For the evaluator, this means going back and redoing
- the dispatch on the car of the form. */
- return NULL;
- }
-
- SCM_SETCAR (vloc, real_var);
- return SCM_VARIABLE_LOC (real_var);
- }
-}
-
-SCM *
-scm_lookupcar (SCM vloc, SCM genv, int check)
-{
- SCM *loc = scm_lookupcar1 (vloc, genv, check);
- if (loc == NULL)
- abort ();
- return loc;
-}
-
-
-/* During execution, look up a symbol in the top level of the given local
- * environment and return the corresponding variable object. If no binding
- * for the symbol can be found, an 'Unbound variable' error is signalled. */
-static SCM
-lazy_memoize_variable (const SCM symbol, const SCM environment)
-{
- const SCM top_level = scm_env_top_level (environment);
- const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
-
- if (scm_is_false (variable))
- error_unbound_variable (symbol);
- else
- return variable;
-}
-
-
-SCM
-scm_eval_car (SCM pair, SCM env)
-{
- return SCM_I_XEVALCAR (pair, env, scm_debug_mode_p);
-}
-
-
-SCM
-scm_eval_body (SCM code, SCM env)
-{
- SCM next;
-
- again:
- next = SCM_CDR (code);
- while (!scm_is_null (next))
- {
- if (SCM_IMP (SCM_CAR (code)))
- {
- if (SCM_ISYMP (SCM_CAR (code)))
- {
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (code)))
- m_expand_body (code, env);
- scm_dynwind_end ();
- goto again;
- }
- }
- else
- SCM_I_XEVAL (SCM_CAR (code), env, scm_debug_mode_p);
- code = next;
- next = SCM_CDR (code);
- }
- return SCM_I_XEVALCAR (code, env, scm_debug_mode_p);
-}
-
-
-/* scm_last_debug_frame contains a pointer to the last debugging information
- * stack frame. It is accessed very often from the debugging evaluator, so it
- * should probably not be indirectly addressed. Better to save and restore it
- * from the current root at any stack swaps.
- */
-
-/* scm_debug_eframe_size is the number of slots available for pseudo
- * stack frames at each real stack frame.
- */
-
-long scm_debug_eframe_size;
-
-int scm_debug_mode_p;
-int scm_check_entry_p;
-int scm_check_apply_p;
-int scm_check_exit_p;
-int scm_check_memoize_p;
-
-long scm_eval_stack;
-
-scm_t_option scm_eval_opts[] = {
- { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
- { 0 }
-};
-
-scm_t_option scm_debug_opts[] = {
- { SCM_OPTION_BOOLEAN, "cheap", 1,
- "*This option is now obsolete. Setting it has no effect." },
- { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
- { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
- { SCM_OPTION_BOOLEAN, "procnames", 1,
- "Record procedure names at definition." },
- { SCM_OPTION_BOOLEAN, "backwards", 0,
- "Display backtrace in anti-chronological order." },
- { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
- { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
- { SCM_OPTION_INTEGER, "frames", 3,
- "Maximum number of tail-recursive frames in backtrace." },
- { SCM_OPTION_INTEGER, "maxdepth", 1000,
- "Maximal number of stored backtrace frames." },
- { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
- { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
- { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
- /* This default stack limit will be overridden by debug.c:init_stack_limit(),
- if we have getrlimit() and the stack limit is not INFINITY. But it is still
- important, as some systems have both the soft and the hard limits set to
- INFINITY; in that case we fall back to this value.
-
- The situation is aggravated by certain compilers, which can consume
- "beaucoup de stack", as they say in France.
-
- See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
- more discussion. This setting is 640 KB on 32-bit arches (should be enough
- for anyone!) or a whoppin' 1280 KB on 64-bit arches.
- */
- { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
- { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
- "Show file names and line numbers "
- "in backtraces when not `#f'. A value of `base' "
- "displays only base names, while `#t' displays full names."},
- { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
- "Warn when deprecated features are used." },
- { 0 },
-};
-
-
-/*
- * this ordering is awkward and illogical, but we maintain it for
- * compatibility. --hwn
- */
-scm_t_option scm_evaluator_trap_table[] = {
- { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
- { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
- { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
- { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
- { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
- { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
- { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." },
- { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." },
- { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The handler for memoization." },
- { 0 }
-};
-
-
-SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
- (SCM setting),
- "Option interface for the evaluation options. Instead of using\n"
- "this procedure directly, use the procedures @code{eval-enable},\n"
- "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
-#define FUNC_NAME s_scm_eval_options_interface
-{
- SCM ans;
-
- scm_dynwind_begin (0);
- scm_dynwind_critical_section (SCM_BOOL_F);
- ans = scm_options (setting,
- scm_eval_opts,
- FUNC_NAME);
- scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
- scm_dynwind_end ();
-
- return ans;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
- (SCM setting),
- "Option interface for the evaluator trap options.")
-#define FUNC_NAME s_scm_evaluator_traps
-{
- SCM ans;
-
-
- scm_options_try (setting,
- scm_evaluator_trap_table,
- FUNC_NAME, 1);
- SCM_CRITICAL_SECTION_START;
- ans = scm_options (setting,
- scm_evaluator_trap_table,
- FUNC_NAME);
-
- /* njrev: same again. */
- SCM_RESET_DEBUG_MODE;
- SCM_CRITICAL_SECTION_END;
- return ans;
-}
-#undef FUNC_NAME
-
-
-
-\f
-
-/* Simple procedure calls
- */
-
-SCM
-scm_call_0 (SCM proc)
-{
- if (SCM_PROGRAM_P (proc))
- return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
- else
- return scm_apply (proc, SCM_EOL, SCM_EOL);
-}
-
-SCM
-scm_call_1 (SCM proc, SCM arg1)
-{
- if (SCM_PROGRAM_P (proc))
- return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
- else
- return scm_apply (proc, arg1, scm_listofnull);
-}
-
-SCM
-scm_call_2 (SCM proc, SCM arg1, SCM arg2)
-{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 2);
- }
- else
- return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
-}
-
-SCM
-scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
-{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2, arg3 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 3);
- }
- else
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
-}
-
-SCM
-scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
-{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2, arg3, arg4 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 4);
- }
- else
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
- scm_cons (arg4, scm_listofnull)));
-}
-
-/* Simple procedure applies
- */
-
-SCM
-scm_apply_0 (SCM proc, SCM args)
-{
- return scm_apply (proc, args, SCM_EOL);
-}
-
-SCM
-scm_apply_1 (SCM proc, SCM arg1, SCM args)
-{
- return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
-}
-
-SCM
-scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
-{
- return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
-}
-
-SCM
-scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
-{
- return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
- SCM_EOL);
-}
-
-/* This code processes the arguments to apply:
-
- (apply PROC ARG1 ... ARGS)
-
- Given a list (ARG1 ... ARGS), this function conses the ARG1
- ... arguments onto the front of ARGS, and returns the resulting
- list. Note that ARGS is a list; thus, the argument to this
- function is a list whose last element is a list.
-
- Apply calls this function, and applies PROC to the elements of the
- result. apply:nconc2last takes care of building the list of
- arguments, given (ARG1 ... ARGS).
-
- Rather than do new consing, apply:nconc2last destroys its argument.
- On that topic, this code came into my care with the following
- beautifully cryptic comment on that topic: "This will only screw
- you if you do (scm_apply scm_apply '( ... ))" If you know what
- they're referring to, send me a patch to this comment. */
-
-SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
- (SCM lst),
- "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
- "conses the @var{arg1} @dots{} arguments onto the front of\n"
- "@var{args}, and returns the resulting list. Note that\n"
- "@var{args} is a list; thus, the argument to this function is\n"
- "a list whose last element is a list.\n"
- "Note: Rather than do new consing, @code{apply:nconc2last}\n"
- "destroys its argument, so use with care.")
-#define FUNC_NAME s_scm_nconc2last
-{
- SCM *lloc;
- SCM_VALIDATE_NONEMPTYLIST (1, lst);
- lloc = &lst;
- while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
- SCM_NULL_OR_NIL_P, but not
- needed in 99.99% of cases,
- and it could seriously hurt
- performance. - Neil */
- lloc = SCM_CDRLOC (*lloc);
- SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
- *lloc = SCM_CAR (*lloc);
- return lst;
-}
-#undef FUNC_NAME
-
-
-
-/* SECTION: The rest of this file is only read once.
- */
-
-/* Trampolines
- *
- * Trampolines make it possible to move procedure application dispatch
- * outside inner loops. The motivation was clean implementation of
- * efficient replacements of R5RS primitives in SRFI-1.
- *
- * The semantics is clear: scm_trampoline_N returns an optimized
- * version of scm_call_N (or NULL if the procedure isn't applicable
- * on N args).
- *
- * Applying the optimization to map and for-each increased efficiency
- * noticeably. For example, (map abs ls) is now 8 times faster than
- * before.
- */
-
-static SCM
-call_subr0_0 (SCM proc)
-{
- return SCM_SUBRF (proc) ();
-}
-
-static SCM
-call_subr1o_0 (SCM proc)
-{
- return SCM_SUBRF (proc) (SCM_UNDEFINED);
-}
-
-static SCM
-call_lsubr_0 (SCM proc)
-{
- return SCM_SUBRF (proc) (SCM_EOL);
-}
-
-SCM
-scm_i_call_closure_0 (SCM proc)
-{
- const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- SCM_EOL,
- SCM_ENV (proc));
- const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
- return result;
-}
-
-scm_t_trampoline_0
-scm_trampoline_0 (SCM proc)
-{
- scm_t_trampoline_0 trampoline;
-
- if (SCM_IMP (proc))
- return NULL;
-
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_0:
- trampoline = call_subr0_0;
- break;
- case scm_tc7_subr_1o:
- trampoline = call_subr1o_0;
- break;
- case scm_tc7_lsubr:
- trampoline = call_lsubr_0;
- break;
- case scm_tcs_closures:
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals) || !scm_is_pair (formals))
- trampoline = scm_i_call_closure_0;
- else
- return NULL;
- break;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- trampoline = scm_call_generic_0;
- else if (SCM_I_OPERATORP (proc))
- trampoline = scm_call_0;
- else
- return NULL;
- break;
- case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_0;
- else
- return NULL;
- break;
- case scm_tc7_asubr:
- case scm_tc7_rpsubr:
- case scm_tc7_gsubr:
- case scm_tc7_pws:
- case scm_tc7_program:
- trampoline = scm_call_0;
- break;
- default:
- return NULL; /* not applicable on zero arguments */
- }
- /* We only reach this point if a valid trampoline was determined. */
-
- /* If debugging is enabled, we want to see all calls to proc on the stack.
- * Thus, we replace the trampoline shortcut with scm_call_0. */
- if (scm_debug_mode_p)
- return scm_call_0;
- else
- return trampoline;
-}
-
-static SCM
-call_subr1_1 (SCM proc, SCM arg1)
-{
- return SCM_SUBRF (proc) (arg1);
-}
-
-static SCM
-call_subr2o_1 (SCM proc, SCM arg1)
-{
- return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
-}
-
-static SCM
-call_lsubr_1 (SCM proc, SCM arg1)
-{
- return SCM_SUBRF (proc) (scm_list_1 (arg1));
-}
-
-static SCM
-call_dsubr_1 (SCM proc, SCM arg1)
-{
- if (SCM_I_INUMP (arg1))
- {
- return (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- return (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
- else if (SCM_BIGP (arg1))
- {
- return (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
- else if (SCM_FRACTIONP (arg1))
- {
- return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
- }
- SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
-}
-
-static SCM
-call_cxr_1 (SCM proc, SCM arg1)
-{
- return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
-}
-
-static SCM
-call_closure_1 (SCM proc, SCM arg1)
-{
- const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_1 (arg1),
- SCM_ENV (proc));
- const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
- return result;
-}
-
-scm_t_trampoline_1
-scm_trampoline_1 (SCM proc)
-{
- scm_t_trampoline_1 trampoline;
-
- if (SCM_IMP (proc))
- return NULL;
-
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_1:
- case scm_tc7_subr_1o:
- trampoline = call_subr1_1;
- break;
- case scm_tc7_subr_2o:
- trampoline = call_subr2o_1;
- break;
- case scm_tc7_lsubr:
- trampoline = call_lsubr_1;
- break;
- case scm_tc7_dsubr:
- trampoline = call_dsubr_1;
- break;
- case scm_tc7_cxr:
- trampoline = call_cxr_1;
- break;
- case scm_tcs_closures:
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (!scm_is_null (formals)
- && (!scm_is_pair (formals) || !scm_is_pair (SCM_CDR (formals))))
- trampoline = call_closure_1;
- else
- return NULL;
- break;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- trampoline = scm_call_generic_1;
- else if (SCM_I_OPERATORP (proc))
- trampoline = scm_call_1;
- else
- return NULL;
- break;
- case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_1;
- else
- return NULL;
- break;
- case scm_tc7_asubr:
- case scm_tc7_rpsubr:
- case scm_tc7_gsubr:
- case scm_tc7_pws:
- case scm_tc7_program:
- trampoline = scm_call_1;
- break;
- default:
- return NULL; /* not applicable on one arg */
- }
- /* We only reach this point if a valid trampoline was determined. */
-
- /* If debugging is enabled, we want to see all calls to proc on the stack.
- * Thus, we replace the trampoline shortcut with scm_call_1. */
- if (scm_debug_mode_p)
- return scm_call_1;
- else
- return trampoline;
-}
-
-static SCM
-call_subr2_2 (SCM proc, SCM arg1, SCM arg2)
-{
- return SCM_SUBRF (proc) (arg1, arg2);
-}
-
-static SCM
-call_lsubr2_2 (SCM proc, SCM arg1, SCM arg2)
-{
- return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL);
-}
-
-static SCM
-call_lsubr_2 (SCM proc, SCM arg1, SCM arg2)
-{
- return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2));
-}
-
-static SCM
-call_closure_2 (SCM proc, SCM arg1, SCM arg2)
-{
- const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_2 (arg1, arg2),
- SCM_ENV (proc));
- const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
- return result;
-}
-
-scm_t_trampoline_2
-scm_trampoline_2 (SCM proc)
-{
- scm_t_trampoline_2 trampoline;
-
- if (SCM_IMP (proc))
- return NULL;
-
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- trampoline = call_subr2_2;
- break;
- case scm_tc7_lsubr_2:
- trampoline = call_lsubr2_2;
- break;
- case scm_tc7_lsubr:
- trampoline = call_lsubr_2;
- break;
- case scm_tcs_closures:
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (!scm_is_null (formals)
- && (!scm_is_pair (formals)
- || (!scm_is_null (SCM_CDR (formals))
- && (!scm_is_pair (SCM_CDR (formals))
- || !scm_is_pair (SCM_CDDR (formals))))))
- trampoline = call_closure_2;
- else
- return NULL;
- break;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- trampoline = scm_call_generic_2;
- else if (SCM_I_OPERATORP (proc))
- trampoline = scm_call_2;
- else
- return NULL;
- break;
- case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_2;
- else
- return NULL;
- break;
- case scm_tc7_gsubr:
- case scm_tc7_pws:
- case scm_tc7_program:
- trampoline = scm_call_2;
- break;
- default:
- return NULL; /* not applicable on two args */
- }
- /* We only reach this point if a valid trampoline was determined. */
-
- /* If debugging is enabled, we want to see all calls to proc on the stack.
- * Thus, we replace the trampoline shortcut with scm_call_2. */
- if (scm_debug_mode_p)
- return scm_call_2;
- else
- return trampoline;
-}
-
-/* Typechecking for multi-argument MAP and FOR-EACH.
-
- Verify that each element of the vector ARGV, except for the first,
- is a proper list whose length is LEN. Attribute errors to WHO,
- and claim that the i'th element of ARGV is WHO's i+2'th argument. */
-static inline void
-check_map_args (SCM argv,
- long len,
- SCM gf,
- SCM proc,
- SCM args,
- const char *who)
-{
- long i;
-
- for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
- long elt_len = scm_ilength (elt);
-
- if (elt_len < 0)
- {
- if (gf)
- scm_apply_generic (gf, scm_cons (proc, args));
- else
- scm_wrong_type_arg (who, i + 2, elt);
- }
-
- if (elt_len != len)
- scm_out_of_range_pos (who, elt, scm_from_long (i + 2));
- }
-}
-
-
-SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
-
-/* Note: Currently, scm_map applies PROC to the argument list(s)
- sequentially, starting with the first element(s). This is used in
- evalext.c where the Scheme procedure `map-in-order', which guarantees
- sequential behaviour, is implemented using scm_map. If the
- behaviour changes, we need to update `map-in-order'.
-*/
-
-SCM
-scm_map (SCM proc, SCM arg1, SCM args)
-#define FUNC_NAME s_map
-{
- long i, len;
- SCM res = SCM_EOL;
- SCM *pres = &res;
-
- len = scm_ilength (arg1);
- SCM_GASSERTn (len >= 0,
- g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
- SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_null (args))
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (proc);
- SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map);
- while (SCM_NIMP (arg1))
- {
- *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
- pres = SCM_CDRLOC (*pres);
- arg1 = SCM_CDR (arg1);
- }
- return res;
- }
- if (scm_is_null (SCM_CDR (args)))
- {
- SCM arg2 = SCM_CAR (args);
- int len2 = scm_ilength (arg2);
- scm_t_trampoline_2 call = scm_trampoline_2 (proc);
- SCM_GASSERTn (call,
- g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
- SCM_GASSERTn (len2 >= 0,
- g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
- if (len2 != len)
- SCM_OUT_OF_RANGE (3, arg2);
- while (SCM_NIMP (arg1))
- {
- *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
- pres = SCM_CDRLOC (*pres);
- arg1 = SCM_CDR (arg1);
- arg2 = SCM_CDR (arg2);
- }
- return res;
- }
- arg1 = scm_cons (arg1, args);
- args = scm_vector (arg1);
- check_map_args (args, len, g_map, proc, arg1, s_map);
- while (1)
- {
- arg1 = SCM_EOL;
- for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
- if (SCM_IMP (elt))
- return res;
- arg1 = scm_cons (SCM_CAR (elt), arg1);
- SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
- }
- *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
- pres = SCM_CDRLOC (*pres);
- }
-}
-#undef FUNC_NAME
-
-
-SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
-
-SCM
-scm_for_each (SCM proc, SCM arg1, SCM args)
-#define FUNC_NAME s_for_each
-{
- long i, len;
- len = scm_ilength (arg1);
- SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
- SCM_ARG2, s_for_each);
- SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_null (args))
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (proc);
- SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each);
- while (SCM_NIMP (arg1))
- {
- call (proc, SCM_CAR (arg1));
- arg1 = SCM_CDR (arg1);
- }
- return SCM_UNSPECIFIED;
- }
- if (scm_is_null (SCM_CDR (args)))
- {
- SCM arg2 = SCM_CAR (args);
- int len2 = scm_ilength (arg2);
- scm_t_trampoline_2 call = scm_trampoline_2 (proc);
- SCM_GASSERTn (call, g_for_each,
- scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
- SCM_GASSERTn (len2 >= 0, g_for_each,
- scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
- if (len2 != len)
- SCM_OUT_OF_RANGE (3, arg2);
- while (SCM_NIMP (arg1))
- {
- call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
- arg1 = SCM_CDR (arg1);
- arg2 = SCM_CDR (arg2);
- }
- return SCM_UNSPECIFIED;
- }
- arg1 = scm_cons (arg1, args);
- args = scm_vector (arg1);
- check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
- while (1)
- {
- arg1 = SCM_EOL;
- for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
- if (SCM_IMP (elt))
- return SCM_UNSPECIFIED;
- arg1 = scm_cons (SCM_CAR (elt), arg1);
- SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
- }
- scm_apply (proc, arg1, SCM_EOL);
- }
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_closure (SCM code, SCM env)
-{
- SCM z;
- SCM closcar = scm_cons (code, SCM_EOL);
- z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env);
- scm_remember_upto_here (closcar);
- return z;
-}
-
-
-scm_t_bits scm_tc16_promise;
-
-SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0,
- (SCM thunk),
- "Create a new promise object.\n\n"
- "@code{make-promise} is a procedural form of @code{delay}.\n"
- "These two expressions are equivalent:\n"
- "@lisp\n"
- "(delay @var{exp})\n"
- "(make-promise (lambda () @var{exp}))\n"
- "@end lisp\n")
-#define FUNC_NAME s_scm_make_promise
-{
- SCM_VALIDATE_THUNK (1, thunk);
- SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
- SCM_UNPACK (thunk),
- scm_make_recursive_mutex ());
-}
-#undef FUNC_NAME
-
-static SCM
-promise_mark (SCM promise)
-{
- scm_gc_mark (SCM_PROMISE_MUTEX (promise));
- return SCM_PROMISE_DATA (promise);
-}
-
-static size_t
-promise_free (SCM promise)
-{
- return 0;
-}
-
-static int
-promise_print (SCM exp, SCM port, scm_print_state *pstate)
-{
- int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<promise ", port);
- SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
- SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
- return !0;
-}
-
-SCM_DEFINE (scm_force, "force", 1, 0, 0,
- (SCM promise),
- "If the promise @var{x} has not been computed yet, compute and\n"
- "return @var{x}, otherwise just return the previously computed\n"
- "value.")
-#define FUNC_NAME s_scm_force
-{
- SCM_VALIDATE_SMOB (1, promise, promise);
- scm_lock_mutex (SCM_PROMISE_MUTEX (promise));
- if (!SCM_PROMISE_COMPUTED_P (promise))
- {
- SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
- if (!SCM_PROMISE_COMPUTED_P (promise))
- {
- SCM_SET_PROMISE_DATA (promise, ans);
- SCM_SET_PROMISE_COMPUTED (promise);
- }
- }
- scm_unlock_mutex (SCM_PROMISE_MUTEX (promise));
- return SCM_PROMISE_DATA (promise);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
- (SCM obj),
- "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
- "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
-#define FUNC_NAME s_scm_promise_p
-{
- return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
- (SCM xorig, SCM x, SCM y),
- "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
- "Any source properties associated with @var{xorig} are also associated\n"
- "with the new pair.")
-#define FUNC_NAME s_scm_cons_source
-{
- SCM p, z;
- z = scm_cons (x, y);
- /* Copy source properties possibly associated with xorig. */
- p = scm_whash_lookup (scm_source_whash, xorig);
- if (scm_is_true (p))
- scm_whash_insert (scm_source_whash, z, p);
- return z;
-}
-#undef FUNC_NAME
-
-
-/* The function scm_copy_tree is used to copy an expression tree to allow the
- * memoizer to modify the expression during memoization. scm_copy_tree
- * creates deep copies of pairs and vectors, but not of any other data types,
- * since only pairs and vectors will be parsed by the memoizer.
- *
- * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
- * pattern is used to detect cycles. In fact, the pattern is used in two
- * dimensions, vertical (indicated in the code by the variable names 'hare'
- * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
- * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
- * takes one.
- *
- * The vertical dimension corresponds to recursive calls to function
- * copy_tree: This happens when descending into vector elements, into cars of
- * lists and into the cdr of an improper list. In this dimension, the
- * tortoise follows the hare by using the processor stack: Every stack frame
- * will hold an instance of struct t_trace. These instances are connected in
- * a way that represents the trace of the hare, which thus can be followed by
- * the tortoise. The tortoise will always point to struct t_trace instances
- * relating to SCM objects that have already been copied. Thus, a cycle is
- * detected if the tortoise and the hare point to the same object,
- *
- * The horizontal dimension is within one execution of copy_tree, when the
- * function cdr's along the pairs of a list. This is the standard
- * hare-and-tortoise implementation, found several times in guile. */
-
-struct t_trace {
- struct t_trace *trace; /* These pointers form a trace along the stack. */
- SCM obj; /* The object handled at the respective stack frame.*/
-};
-
-static SCM
-copy_tree (
- struct t_trace *const hare,
- struct t_trace *tortoise,
- unsigned int tortoise_delay )
-{
- if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
- {
- return hare->obj;
- }
- else
- {
- /* Prepare the trace along the stack. */
- struct t_trace new_hare;
- hare->trace = &new_hare;
-
- /* The tortoise will make its step after the delay has elapsed. Note
- * that in contrast to the typical hare-and-tortoise pattern, the step
- * of the tortoise happens before the hare takes its steps. This is, in
- * principle, no problem, except for the start of the algorithm: Then,
- * it has to be made sure that the hare actually gets its advantage of
- * two steps. */
- if (tortoise_delay == 0)
- {
- tortoise_delay = 1;
- tortoise = tortoise->trace;
- ASSERT_SYNTAX (!scm_is_eq (hare->obj, tortoise->obj),
- s_bad_expression, hare->obj);
- }
- else
- {
- --tortoise_delay;
- }
-
- if (scm_is_simple_vector (hare->obj))
- {
- size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
- SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
-
- /* Each vector element is copied by recursing into copy_tree, having
- * the tortoise follow the hare into the depths of the stack. */
- unsigned long int i;
- for (i = 0; i < length; ++i)
- {
- SCM new_element;
- new_hare.obj = SCM_SIMPLE_VECTOR_REF (hare->obj, i);
- new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
- SCM_SIMPLE_VECTOR_SET (new_vector, i, new_element);
- }
-
- return new_vector;
- }
- else /* scm_is_pair (hare->obj) */
- {
- SCM result;
- SCM tail;
-
- SCM rabbit = hare->obj;
- SCM turtle = hare->obj;
-
- SCM copy;
-
- /* The first pair of the list is treated specially, in order to
- * preserve a potential source code position. */
- result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
- new_hare.obj = SCM_CAR (rabbit);
- copy = copy_tree (&new_hare, tortoise, tortoise_delay);
- SCM_SETCAR (tail, copy);
-
- /* The remaining pairs of the list are copied by, horizontally,
- * having the turtle follow the rabbit, and, vertically, having the
- * tortoise follow the hare into the depths of the stack. */
- rabbit = SCM_CDR (rabbit);
- while (scm_is_pair (rabbit))
- {
- new_hare.obj = SCM_CAR (rabbit);
- copy = copy_tree (&new_hare, tortoise, tortoise_delay);
- SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
- tail = SCM_CDR (tail);
-
- rabbit = SCM_CDR (rabbit);
- if (scm_is_pair (rabbit))
- {
- new_hare.obj = SCM_CAR (rabbit);
- copy = copy_tree (&new_hare, tortoise, tortoise_delay);
- SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
- tail = SCM_CDR (tail);
- rabbit = SCM_CDR (rabbit);
-
- turtle = SCM_CDR (turtle);
- ASSERT_SYNTAX (!scm_is_eq (rabbit, turtle),
- s_bad_expression, rabbit);
- }
- }
-
- /* We have to recurse into copy_tree again for the last cdr, in
- * order to handle the situation that it holds a vector. */
- new_hare.obj = rabbit;
- copy = copy_tree (&new_hare, tortoise, tortoise_delay);
- SCM_SETCDR (tail, copy);
-
- return result;
- }
- }
-}
-
-SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
- (SCM obj),
- "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
- "the new data structure. @code{copy-tree} recurses down the\n"
- "contents of both pairs and vectors (since both cons cells and vector\n"
- "cells may point to arbitrary objects), and stops recursing when it hits\n"
- "any other object.")
-#define FUNC_NAME s_scm_copy_tree
-{
- /* Prepare the trace along the stack. */
- struct t_trace trace;
- trace.obj = obj;
-
- /* In function copy_tree, if the tortoise makes its step, it will do this
- * before the hare has the chance to move. Thus, we have to make sure that
- * the very first step of the tortoise will not happen after the hare has
- * really made two steps. This is achieved by passing '2' as the initial
- * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
- * a bigger advantage may improve performance slightly. */
- return copy_tree (&trace, &trace, 2);
-}
-#undef FUNC_NAME
-
-
-/* We have three levels of EVAL here:
-
- - scm_i_eval (exp, env)
-
- evaluates EXP in environment ENV. ENV is a lexical environment
- structure as used by the actual tree code evaluator. When ENV is
- a top-level environment, then changes to the current module are
- tracked by updating ENV so that it continues to be in sync with
- the current module.
-
- - scm_primitive_eval (exp)
-
- evaluates EXP in the top-level environment as determined by the
- current module. This is done by constructing a suitable
- environment and calling scm_i_eval. Thus, changes to the
- top-level module are tracked normally.
-
- - scm_eval (exp, mod_or_state)
-
- evaluates EXP while MOD_OR_STATE is the current module or current
- dynamic state (as appropriate). This is done by setting the
- current module (or dynamic state) to MOD_OR_STATE, invoking
- scm_primitive_eval on EXP, and then restoring the current module
- (or dynamic state) to the value it had previously. That is,
- while EXP is evaluated, changes to the current module (or dynamic
- state) are tracked, but these changes do not persist when
- scm_eval returns.
-
- For each level of evals, there are two variants, distinguished by a
- _x suffix: the ordinary variant does not modify EXP while the _x
- variant can destructively modify EXP into something completely
- unintelligible. A Scheme data structure passed as EXP to one of the
- _x variants should not ever be used again for anything. So when in
- doubt, use the ordinary variant.
-
-*/
-
-SCM
-scm_i_eval_x (SCM exp, SCM env)
-{
- if (scm_is_symbol (exp))
- return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
- else
- return SCM_I_XEVAL (exp, env, scm_debug_mode_p);
-}
-
-SCM
-scm_i_eval (SCM exp, SCM env)
-{
- exp = scm_copy_tree (exp);
- if (scm_is_symbol (exp))
- return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
- else
- return SCM_I_XEVAL (exp, env, scm_debug_mode_p);
-}
-
-SCM
-scm_primitive_eval_x (SCM exp)
-{
- SCM env;
- SCM transformer = scm_current_module_transformer ();
- if (SCM_NIMP (transformer))
- exp = scm_call_1 (transformer, exp);
- env = scm_top_level_env (scm_current_module_lookup_closure ());
- return scm_i_eval_x (exp, env);
-}
-
-SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
- (SCM exp),
- "Evaluate @var{exp} in the top-level environment specified by\n"
- "the current module.")
-#define FUNC_NAME s_scm_primitive_eval
-{
- SCM env;
- SCM transformer = scm_current_module_transformer ();
- if (scm_is_true (transformer))
- exp = scm_call_1 (transformer, exp);
- env = scm_top_level_env (scm_current_module_lookup_closure ());
- return scm_i_eval (exp, env);
-}
-#undef FUNC_NAME
-
-
-/* Eval does not take the second arg optionally. This is intentional
- * in order to be R5RS compatible, and to prepare for the new module
- * system, where we would like to make the choice of evaluation
- * environment explicit. */
-
-SCM
-scm_eval_x (SCM exp, SCM module_or_state)
-{
- SCM res;
-
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- if (scm_is_dynamic_state (module_or_state))
- scm_dynwind_current_dynamic_state (module_or_state);
- else
- scm_dynwind_current_module (module_or_state);
-
- res = scm_primitive_eval_x (exp);
-
- scm_dynwind_end ();
- return res;
-}
-
-SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
- (SCM exp, SCM module_or_state),
- "Evaluate @var{exp}, a list representing a Scheme expression,\n"
- "in the top-level environment specified by\n"
- "@var{module_or_state}.\n"
- "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
- "@var{module_or_state} is made the current module when\n"
- "it is a module, or the current dynamic state when it is\n"
- "a dynamic state."
- "Example: (eval '(+ 1 2) (interaction-environment))")
-#define FUNC_NAME s_scm_eval
-{
- SCM res;
-
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- if (scm_is_dynamic_state (module_or_state))
- scm_dynwind_current_dynamic_state (module_or_state);
- else if (scm_module_system_booted_p)
- {
- SCM_VALIDATE_MODULE (2, module_or_state);
- scm_dynwind_current_module (module_or_state);
- }
- /* otherwise if the module system isn't booted, ignore the module arg */
-
- res = scm_primitive_eval (exp);
-
- scm_dynwind_end ();
- return res;
-}
-#undef FUNC_NAME
-
-
-/* At this point, deval and scm_dapply are generated.
- */
-
-#define DEVAL
-#include "eval.i.c"
-#undef DEVAL
-#include "eval.i.c"
-
-
-void
-scm_init_eval ()
-{
- scm_i_pthread_mutex_init (&source_mutex,
- scm_i_pthread_mutexattr_recursive);
-
- scm_init_opts (scm_evaluator_traps,
- scm_evaluator_trap_table);
- scm_init_opts (scm_eval_options_interface,
- scm_eval_opts);
-
- scm_tc16_promise = scm_make_smob_type ("promise", 0);
- scm_set_smob_mark (scm_tc16_promise, promise_mark);
- scm_set_smob_free (scm_tc16_promise, promise_free);
- scm_set_smob_print (scm_tc16_promise, promise_print);
-
- undefineds = scm_list_1 (SCM_UNDEFINED);
- SCM_SETCDR (undefineds, undefineds);
- scm_permanent_object (undefineds);
-
- scm_listofnull = scm_list_1 (SCM_EOL);
-
- f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
- scm_permanent_object (f_apply);
-
-#include "libguile/eval.x"
-
- scm_add_feature ("delay");
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
-
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+ * 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
+ */
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
+#include "libguile/__scm.h"
+
+#include <assert.h>
+#include "libguile/_scm.h"
+#include "libguile/alist.h"
+#include "libguile/async.h"
+#include "libguile/continuations.h"
+#include "libguile/debug.h"
+#include "libguile/deprecation.h"
+#include "libguile/dynwind.h"
+#include "libguile/eq.h"
+#include "libguile/feature.h"
+#include "libguile/fluids.h"
+#include "libguile/goops.h"
+#include "libguile/hash.h"
+#include "libguile/hashtab.h"
+#include "libguile/lang.h"
+#include "libguile/list.h"
+#include "libguile/macros.h"
+#include "libguile/memoize.h"
+#include "libguile/modules.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/procprop.h"
+#include "libguile/programs.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/strings.h"
+#include "libguile/threads.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/vectors.h"
+#include "libguile/vm.h"
+
+#include "libguile/eval.h"
+#include "libguile/private-options.h"
+
+\f
+
+
+/* We have three levels of EVAL here:
+
+ - eval (exp, env)
+
+ evaluates EXP in environment ENV. ENV is a lexical environment
+ structure as used by the actual tree code evaluator. When ENV is
+ a top-level environment, then changes to the current module are
+ tracked by updating ENV so that it continues to be in sync with
+ the current module.
+
+ - scm_primitive_eval (exp)
+
+ evaluates EXP in the top-level environment as determined by the
+ current module. This is done by constructing a suitable
+ environment and calling eval. Thus, changes to the
+ top-level module are tracked normally.
+
+ - scm_eval (exp, mod)
+
+ evaluates EXP while MOD is the current module. This is done
+ by setting the current module to MOD_OR_STATE, invoking
+ scm_primitive_eval on EXP, and then restoring the current module
+ to the value it had previously. That is, while EXP is evaluated,
+ changes to the current module (or dynamic state) are tracked,
+ but these changes do not persist when scm_eval returns.
+
+*/
+
+
+/* Boot closures. We only see these when compiling eval.scm, because once
+ eval.scm is in the house, closures are standard VM closures.
+ */
+
+static scm_t_bits scm_tc16_boot_closure;
+#define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, (code), (env))
+#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
+#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
+#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
+#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CAR (BOOT_CLOSURE_CODE (x)))
+#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADR (BOOT_CLOSURE_CODE (x)))
+#define BOOT_CLOSURE_BODY(x) CDDR (BOOT_CLOSURE_CODE (x))
+
+
+
+#if 0
+#define CAR(x) SCM_CAR(x)
+#define CDR(x) SCM_CDR(x)
+#define CAAR(x) SCM_CAAR(x)
+#define CADR(x) SCM_CADR(x)
+#define CDAR(x) SCM_CDAR(x)
+#define CDDR(x) SCM_CDDR(x)
+#define CADDR(x) SCM_CADDR(x)
+#define CDDDR(x) SCM_CDDDR(x)
+#else
+#define CAR(x) scm_car(x)
+#define CDR(x) scm_cdr(x)
+#define CAAR(x) scm_caar(x)
+#define CADR(x) scm_cadr(x)
+#define CDAR(x) scm_cdar(x)
+#define CDDR(x) scm_cddr(x)
+#define CADDR(x) scm_caddr(x)
+#define CDDDR(x) scm_cdddr(x)
+#endif
+
+
+SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+
+static void error_used_before_defined (void)
+{
+ scm_error (scm_unbound_variable_key, NULL,
+ "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
+}
+
+int
+scm_badargsp (SCM formals, SCM args)
+{
+ while (!scm_is_null (formals))
+ {
+ if (!scm_is_pair (formals))
+ return 0;
+ if (scm_is_null (args))
+ return 1;
+ formals = CDR (formals);
+ args = CDR (args);
+ }
+ return !scm_is_null (args) ? 1 : 0;
+}
+
+/* the environment:
+ (VAL ... . MOD)
+ If MOD is #f, it means the environment was captured before modules were
+ booted.
+ If MOD is the literal value '(), we are evaluating at the top level, and so
+ should track changes to the current module. You have to be careful in this
+ case, because further lexical contours should capture the current module.
+*/
+#define CAPTURE_ENV(env) \
+ ((env == SCM_EOL) ? scm_current_module () : \
+ ((env == SCM_BOOL_F) ? scm_the_root_module () : env))
+
+static SCM
+eval (SCM x, SCM env)
+{
+ SCM mx;
+ SCM proc = SCM_UNDEFINED, args = SCM_EOL;
+
+ loop:
+ SCM_TICK;
+ if (!SCM_MEMOIZED_P (x))
+ abort ();
+
+ mx = SCM_MEMOIZED_ARGS (x);
+ switch (SCM_MEMOIZED_TAG (x))
+ {
+ case SCM_M_BEGIN:
+ for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
+ eval (CAR (mx), env);
+ x = CAR (mx);
+ goto loop;
+
+ case SCM_M_IF:
+ if (scm_is_true (eval (CAR (mx), env)))
+ x = CADR (mx);
+ else
+ x = CDDR (mx);
+ goto loop;
+
+ case SCM_M_LET:
+ {
+ SCM inits = CAR (mx);
+ SCM new_env = CAPTURE_ENV (env);
+ for (; scm_is_pair (inits); inits = CDR (inits))
+ new_env = scm_cons (eval (CAR (inits), env), new_env);
+ env = new_env;
+ x = CDR (mx);
+ goto loop;
+ }
+
+ case SCM_M_LAMBDA:
+ RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
+
+ case SCM_M_QUOTE:
+ return mx;
+
+ case SCM_M_DEFINE:
+ scm_define (CAR (mx), eval (CDR (mx), env));
+ return SCM_UNSPECIFIED;
+
+ case SCM_M_APPLY:
+ /* Evaluate the procedure to be applied. */
+ proc = eval (CAR (mx), env);
+ /* Evaluate the argument holding the list of arguments */
+ args = eval (CADR (mx), env);
+
+ apply_proc:
+ /* Go here to tail-apply a procedure. PROC is the procedure and
+ * ARGS is the list of arguments. */
+ if (BOOT_CLOSURE_P (proc))
+ {
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = BOOT_CLOSURE_ENV (proc);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) < nreq))
+ scm_wrong_num_args (proc);
+ for (; nreq; nreq--, args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ new_env = scm_cons (args, new_env);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) != nreq))
+ scm_wrong_num_args (proc);
+ for (; scm_is_pair (args); args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ }
+ x = BOOT_CLOSURE_BODY (proc);
+ env = new_env;
+ goto loop;
+ }
+ else
+ return scm_vm_apply (scm_the_vm (), proc, args);
+
+ case SCM_M_CALL:
+ /* Evaluate the procedure to be applied. */
+ proc = eval (CAR (mx), env);
+
+ mx = CDR (mx);
+
+ if (BOOT_CLOSURE_P (proc))
+ {
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = BOOT_CLOSURE_ENV (proc);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
+ {
+ if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
+ scm_wrong_num_args (proc);
+ for (; nreq; nreq--, mx = CDR (mx))
+ new_env = scm_cons (eval (CAR (mx), env), new_env);
+ {
+ SCM rest = SCM_EOL;
+ for (; scm_is_pair (mx); mx = CDR (mx))
+ rest = scm_cons (eval (CAR (mx), env), rest);
+ new_env = scm_cons (scm_reverse (rest),
+ new_env);
+ }
+ }
+ else
+ {
+ for (; scm_is_pair (mx); mx = CDR (mx), nreq--)
+ new_env = scm_cons (eval (CAR (mx), env), new_env);
+ if (SCM_UNLIKELY (nreq != 0))
+ scm_wrong_num_args (proc);
+ }
+ x = BOOT_CLOSURE_BODY (proc);
+ env = new_env;
+ goto loop;
+ }
+ else
+ {
+ SCM rest = SCM_EOL;
+ for (; scm_is_pair (mx); mx = CDR (mx))
+ rest = scm_cons (eval (CAR (mx), env), rest);
+ return scm_vm_apply (scm_the_vm (), proc, scm_reverse (rest));
+ }
+
+ case SCM_M_CONT:
+ {
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (!first)
+ return val;
+ else
+ {
+ proc = eval (mx, env);
+ args = scm_list_1 (val);
+ goto apply_proc;
+ }
+ }
+
+ case SCM_M_CALL_WITH_VALUES:
+ {
+ SCM producer;
+ SCM v;
+
+ producer = eval (CAR (mx), env);
+ proc = eval (CDR (mx), env); /* proc is the consumer. */
+ v = scm_vm_apply (scm_the_vm (), producer, SCM_EOL);
+ if (SCM_VALUESP (v))
+ args = scm_struct_ref (v, SCM_INUM0);
+ else
+ args = scm_list_1 (v);
+ goto apply_proc;
+ }
+
+ case SCM_M_LEXICAL_REF:
+ {
+ int n;
+ SCM ret;
+ for (n = SCM_I_INUM (mx); n; n--)
+ env = CDR (env);
+ ret = CAR (env);
+ if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
+ /* we don't know what variable, though, because we don't have its
+ name */
+ error_used_before_defined ();
+ return ret;
+ }
+
+ case SCM_M_LEXICAL_SET:
+ {
+ int n;
+ SCM val = eval (CDR (mx), env);
+ for (n = SCM_I_INUM (CAR (mx)); n; n--)
+ env = CDR (env);
+ SCM_SETCAR (env, val);
+ return SCM_UNSPECIFIED;
+ }
+
+ case SCM_M_TOPLEVEL_REF:
+ if (SCM_VARIABLEP (mx))
+ return SCM_VARIABLE_REF (mx);
+ else
+ {
+ while (scm_is_pair (env))
+ env = scm_cdr (env);
+ return SCM_VARIABLE_REF
+ (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
+ }
+
+ case SCM_M_TOPLEVEL_SET:
+ {
+ SCM var = CAR (mx);
+ SCM val = eval (CDR (mx), env);
+ if (SCM_VARIABLEP (var))
+ {
+ SCM_VARIABLE_SET (var, val);
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ while (scm_is_pair (env))
+ env = scm_cdr (env);
+ SCM_VARIABLE_SET
+ (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
+ val);
+ return SCM_UNSPECIFIED;
+ }
+ }
+
+ case SCM_M_MODULE_REF:
+ if (SCM_VARIABLEP (mx))
+ return SCM_VARIABLE_REF (mx);
+ else
+ return SCM_VARIABLE_REF
+ (scm_memoize_variable_access_x (x, SCM_BOOL_F));
+
+ case SCM_M_MODULE_SET:
+ if (SCM_VARIABLEP (CDR (mx)))
+ {
+ SCM_VARIABLE_SET (CDR (mx), eval (CAR (mx), env));
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ SCM_VARIABLE_SET
+ (scm_memoize_variable_access_x (x, SCM_BOOL_F),
+ eval (CAR (mx), env));
+ return SCM_UNSPECIFIED;
+ }
+
+ default:
+ abort ();
+ }
+}
+
+scm_t_option scm_eval_opts[] = {
+ { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
+ { 0 }
+};
+
+scm_t_option scm_debug_opts[] = {
+ { SCM_OPTION_BOOLEAN, "cheap", 1,
+ "*This option is now obsolete. Setting it has no effect." },
+ { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
+ { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
+ { SCM_OPTION_BOOLEAN, "procnames", 1,
+ "Record procedure names at definition." },
+ { SCM_OPTION_BOOLEAN, "backwards", 0,
+ "Display backtrace in anti-chronological order." },
+ { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
+ { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
+ { SCM_OPTION_INTEGER, "frames", 3,
+ "Maximum number of tail-recursive frames in backtrace." },
+ { SCM_OPTION_INTEGER, "maxdepth", 1000,
+ "Maximal number of stored backtrace frames." },
+ { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
+ { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
+ { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
+ /* This default stack limit will be overridden by debug.c:init_stack_limit(),
+ if we have getrlimit() and the stack limit is not INFINITY. But it is still
+ important, as some systems have both the soft and the hard limits set to
+ INFINITY; in that case we fall back to this value.
+
+ The situation is aggravated by certain compilers, which can consume
+ "beaucoup de stack", as they say in France.
+
+ See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
+ more discussion. This setting is 640 KB on 32-bit arches (should be enough
+ for anyone!) or a whoppin' 1280 KB on 64-bit arches.
+ */
+ { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
+ { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
+ "Show file names and line numbers "
+ "in backtraces when not `#f'. A value of `base' "
+ "displays only base names, while `#t' displays full names."},
+ { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
+ "Warn when deprecated features are used." },
+ { 0 },
+};
+
+
+/*
+ * this ordering is awkward and illogical, but we maintain it for
+ * compatibility. --hwn
+ */
+scm_t_option scm_evaluator_trap_table[] = {
+ { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
+ { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
+ { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
+ { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
+ { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
+ { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
+ { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." },
+ { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." },
+ { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The handler for memoization." },
+ { 0 }
+};
+
+
+SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the evaluation options. Instead of using\n"
+ "this procedure directly, use the procedures @code{eval-enable},\n"
+ "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
+#define FUNC_NAME s_scm_eval_options_interface
+{
+ SCM ans;
+
+ scm_dynwind_begin (0);
+ scm_dynwind_critical_section (SCM_BOOL_F);
+ ans = scm_options (setting,
+ scm_eval_opts,
+ FUNC_NAME);
+ scm_dynwind_end ();
+
+ return ans;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the evaluator trap options.")
+#define FUNC_NAME s_scm_evaluator_traps
+{
+ SCM ans;
+
+
+ scm_options_try (setting,
+ scm_evaluator_trap_table,
+ FUNC_NAME, 1);
+ SCM_CRITICAL_SECTION_START;
+ ans = scm_options (setting,
+ scm_evaluator_trap_table,
+ FUNC_NAME);
+
+ /* njrev: same again. */
+ SCM_CRITICAL_SECTION_END;
+ return ans;
+}
+#undef FUNC_NAME
+
+
+
+\f
+
+/* Simple procedure calls
+ */
+
+SCM
+scm_call_0 (SCM proc)
+{
+ return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
+}
+
+SCM
+scm_call_1 (SCM proc, SCM arg1)
+{
+ return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
+}
+
+SCM
+scm_call_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ SCM args[] = { arg1, arg2 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 2);
+}
+
+SCM
+scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
+{
+ SCM args[] = { arg1, arg2, arg3 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 3);
+}
+
+SCM
+scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
+{
+ SCM args[] = { arg1, arg2, arg3, arg4 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 4);
+}
+
+/* Simple procedure applies
+ */
+
+SCM
+scm_apply_0 (SCM proc, SCM args)
+{
+ return scm_apply (proc, args, SCM_EOL);
+}
+
+SCM
+scm_apply_1 (SCM proc, SCM arg1, SCM args)
+{
+ return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
+}
+
+SCM
+scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
+{
+ return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
+}
+
+SCM
+scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
+{
+ return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
+ SCM_EOL);
+}
+
+/* This code processes the arguments to apply:
+
+ (apply PROC ARG1 ... ARGS)
+
+ Given a list (ARG1 ... ARGS), this function conses the ARG1
+ ... arguments onto the front of ARGS, and returns the resulting
+ list. Note that ARGS is a list; thus, the argument to this
+ function is a list whose last element is a list.
+
+ Apply calls this function, and applies PROC to the elements of the
+ result. apply:nconc2last takes care of building the list of
+ arguments, given (ARG1 ... ARGS).
+
+ Rather than do new consing, apply:nconc2last destroys its argument.
+ On that topic, this code came into my care with the following
+ beautifully cryptic comment on that topic: "This will only screw
+ you if you do (scm_apply scm_apply '( ... ))" If you know what
+ they're referring to, send me a patch to this comment. */
+
+SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
+ (SCM lst),
+ "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
+ "conses the @var{arg1} @dots{} arguments onto the front of\n"
+ "@var{args}, and returns the resulting list. Note that\n"
+ "@var{args} is a list; thus, the argument to this function is\n"
+ "a list whose last element is a list.\n"
+ "Note: Rather than do new consing, @code{apply:nconc2last}\n"
+ "destroys its argument, so use with care.")
+#define FUNC_NAME s_scm_nconc2last
+{
+ SCM *lloc;
+ SCM_VALIDATE_NONEMPTYLIST (1, lst);
+ lloc = &lst;
+ while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
+ SCM_NULL_OR_NIL_P, but not
+ needed in 99.99% of cases,
+ and it could seriously hurt
+ performance. - Neil */
+ lloc = SCM_CDRLOC (*lloc);
+ SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
+ *lloc = SCM_CAR (*lloc);
+ return lst;
+}
+#undef FUNC_NAME
+
+
+
+/* Typechecking for multi-argument MAP and FOR-EACH.
+
+ Verify that each element of the vector ARGV, except for the first,
+ is a proper list whose length is LEN. Attribute errors to WHO,
+ and claim that the i'th element of ARGV is WHO's i+2'th argument. */
+static inline void
+check_map_args (SCM argv,
+ long len,
+ SCM gf,
+ SCM proc,
+ SCM args,
+ const char *who)
+{
+ long i;
+
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
+ long elt_len = scm_ilength (elt);
+
+ if (elt_len < 0)
+ {
+ if (gf)
+ scm_apply_generic (gf, scm_cons (proc, args));
+ else
+ scm_wrong_type_arg (who, i + 2, elt);
+ }
+
+ if (elt_len != len)
+ scm_out_of_range_pos (who, elt, scm_from_long (i + 2));
+ }
+}
+
+
+SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
+
+/* Note: Currently, scm_map applies PROC to the argument list(s)
+ sequentially, starting with the first element(s). This is used in
+ evalext.c where the Scheme procedure `map-in-order', which guarantees
+ sequential behaviour, is implemented using scm_map. If the
+ behaviour changes, we need to update `map-in-order'.
+*/
+
+SCM
+scm_map (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_map
+{
+ long i, len;
+ SCM res = SCM_EOL;
+ SCM *pres = &res;
+
+ len = scm_ilength (arg1);
+ SCM_GASSERTn (len >= 0,
+ g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (scm_is_null (args))
+ {
+ SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_map, proc, arg1, SCM_ARG1, s_map);
+ while (SCM_NIMP (arg1))
+ {
+ *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ }
+ return res;
+ }
+ if (scm_is_null (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = scm_ilength (arg2);
+ SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_map,
+ scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
+ SCM_GASSERTn (len2 >= 0,
+ g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
+ if (len2 != len)
+ SCM_OUT_OF_RANGE (3, arg2);
+ while (SCM_NIMP (arg1))
+ {
+ *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
+ }
+ return res;
+ }
+ arg1 = scm_cons (arg1, args);
+ args = scm_vector (arg1);
+ check_map_args (args, len, g_map, proc, arg1, s_map);
+ while (1)
+ {
+ arg1 = SCM_EOL;
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
+ if (SCM_IMP (elt))
+ return res;
+ arg1 = scm_cons (SCM_CAR (elt), arg1);
+ SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
+ }
+ *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
+ pres = SCM_CDRLOC (*pres);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
+
+SCM
+scm_for_each (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_for_each
+{
+ long i, len;
+ len = scm_ilength (arg1);
+ SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
+ SCM_ARG2, s_for_each);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (scm_is_null (args))
+ {
+ SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_for_each,
+ proc, arg1, SCM_ARG1, s_for_each);
+ while (SCM_NIMP (arg1))
+ {
+ scm_call_1 (proc, SCM_CAR (arg1));
+ arg1 = SCM_CDR (arg1);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ if (scm_is_null (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = scm_ilength (arg2);
+ SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_for_each,
+ scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
+ SCM_GASSERTn (len2 >= 0, g_for_each,
+ scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
+ if (len2 != len)
+ SCM_OUT_OF_RANGE (3, arg2);
+ while (SCM_NIMP (arg1))
+ {
+ scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2));
+ arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ arg1 = scm_cons (arg1, args);
+ args = scm_vector (arg1);
+ check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
+ while (1)
+ {
+ arg1 = SCM_EOL;
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
+ if (SCM_IMP (elt))
+ return SCM_UNSPECIFIED;
+ arg1 = scm_cons (SCM_CAR (elt), arg1);
+ SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
+ }
+ scm_apply (proc, arg1, SCM_EOL);
+ }
+}
+#undef FUNC_NAME
+
+
+static SCM
+scm_c_primitive_eval (SCM exp)
+{
+ SCM transformer = scm_current_module_transformer ();
+ if (scm_is_true (transformer))
+ exp = scm_call_1 (transformer, exp);
+ exp = scm_memoize_expression (exp);
+ return eval (exp, SCM_EOL);
+}
+
+static SCM var_primitive_eval;
+SCM
+scm_primitive_eval (SCM exp)
+{
+ return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
+ &exp, 1);
+}
+
+
+/* Eval does not take the second arg optionally. This is intentional
+ * in order to be R5RS compatible, and to prepare for the new module
+ * system, where we would like to make the choice of evaluation
+ * environment explicit. */
+
+SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
+ (SCM exp, SCM module_or_state),
+ "Evaluate @var{exp}, a list representing a Scheme expression,\n"
+ "in the top-level environment specified by\n"
+ "@var{module_or_state}.\n"
+ "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
+ "@var{module_or_state} is made the current module when\n"
+ "it is a module, or the current dynamic state when it is\n"
+ "a dynamic state."
+ "Example: (eval '(+ 1 2) (interaction-environment))")
+#define FUNC_NAME s_scm_eval
+{
+ SCM res;
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ if (scm_is_dynamic_state (module_or_state))
+ scm_dynwind_current_dynamic_state (module_or_state);
+ else if (scm_module_system_booted_p)
+ {
+ SCM_VALIDATE_MODULE (2, module_or_state);
+ scm_dynwind_current_module (module_or_state);
+ }
+ /* otherwise if the module system isn't booted, ignore the module arg */
+
+ res = scm_primitive_eval (exp);
+
+ scm_dynwind_end ();
+ return res;
+}
+#undef FUNC_NAME
+
+
+static SCM f_apply;
+
+/* Apply a function to a list of arguments.
+
+ This function is exported to the Scheme level as taking two
+ required arguments and a tail argument, as if it were:
+ (lambda (proc arg1 . args) ...)
+ Thus, if you just have a list of arguments to pass to a procedure,
+ pass the list as ARG1, and '() for ARGS. If you have some fixed
+ args, pass the first as ARG1, then cons any remaining fixed args
+ onto the front of your argument list, and pass that as ARGS. */
+
+SCM
+scm_apply (SCM proc, SCM arg1, SCM args)
+{
+ /* Fix things up so that args contains all args. */
+ if (scm_is_null (args))
+ args = arg1;
+ else
+ args = scm_cons_star (arg1, args);
+
+ return scm_vm_apply (scm_the_vm (), proc, args);
+}
+
+
+static SCM
+boot_closure_apply (SCM closure, SCM args)
+{
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure);
+ SCM new_env = BOOT_CLOSURE_ENV (closure);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) < nreq))
+ scm_wrong_num_args (closure);
+ for (; nreq; nreq--, args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ new_env = scm_cons (args, new_env);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) != nreq))
+ scm_wrong_num_args (closure);
+ for (; scm_is_pair (args); args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ }
+ return eval (BOOT_CLOSURE_BODY (closure), new_env);
+}
+
+static int
+boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
+{
+ SCM args;
+ scm_puts ("#<boot-closure ", port);
+ scm_uintprint ((unsigned long)SCM2PTR (closure), 16, port);
+ scm_putc (' ', port);
+ args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
+ scm_from_locale_symbol ("_"));
+ if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ args = scm_cons_star (scm_from_locale_symbol ("_"), args);
+ scm_display (args, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+void
+scm_init_eval ()
+{
+ SCM primitive_eval;
+
+ scm_init_opts (scm_evaluator_traps,
+ scm_evaluator_trap_table);
+ scm_init_opts (scm_eval_options_interface,
+ scm_eval_opts);
+
+ f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
+
+ scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
+ scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
+ scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
+
+ primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
+ scm_c_primitive_eval);
+ var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
+ primitive_eval);
+
+#include "libguile/eval.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
+
#include "libguile/__scm.h"
#include "libguile/struct.h"
+#include "libguile/memoize.h"
\f
\f
-/* {Promises}
- */
-
-#define SCM_F_PROMISE_COMPUTED (1L << 0)
-#define SCM_PROMISE_COMPUTED_P(promise) \
- (SCM_F_PROMISE_COMPUTED & SCM_SMOB_FLAGS (promise))
-#define SCM_SET_PROMISE_COMPUTED(promise) \
- SCM_SET_SMOB_FLAGS ((promise), SCM_F_PROMISE_COMPUTED)
-#define SCM_PROMISE_MUTEX SCM_SMOB_OBJECT_2
-#define SCM_PROMISE_DATA SCM_SMOB_OBJECT
-#define SCM_SET_PROMISE_DATA SCM_SET_SMOB_OBJECT
-
-
-SCM_API scm_t_bits scm_tc16_promise;
-
-\f
-
/* {Evaluator}
*/
\f
-SCM_API SCM scm_sym_and;
-SCM_API SCM scm_sym_begin;
-SCM_API SCM scm_sym_case;
-SCM_API SCM scm_sym_cond;
-SCM_API SCM scm_sym_define;
-SCM_API SCM scm_sym_do;
-SCM_API SCM scm_sym_if;
-SCM_API SCM scm_sym_lambda;
-SCM_API SCM scm_sym_let;
-SCM_API SCM scm_sym_letstar;
-SCM_API SCM scm_sym_letrec;
-SCM_API SCM scm_sym_quote;
-SCM_API SCM scm_sym_quasiquote;
-SCM_API SCM scm_sym_unquote;
-SCM_API SCM scm_sym_uq_splicing;
-
-SCM_API SCM scm_sym_at;
-SCM_API SCM scm_sym_atat;
-SCM_API SCM scm_sym_atapply;
-SCM_API SCM scm_sym_atcall_cc;
-SCM_API SCM scm_sym_at_call_with_values;
-SCM_API SCM scm_sym_delay;
-SCM_API SCM scm_sym_eval_when;
-SCM_API SCM scm_sym_arrow;
-SCM_API SCM scm_sym_else;
-SCM_API SCM scm_sym_apply;
-SCM_API SCM scm_sym_set_x;
-SCM_API SCM scm_sym_args;
-
-\f
-
-SCM_API SCM * scm_ilookup (SCM iloc, SCM env);
-SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check);
-SCM_API SCM scm_eval_car (SCM pair, SCM env);
-SCM_API SCM scm_eval_body (SCM code, SCM env);
-SCM_API SCM scm_eval_args (SCM i, SCM env, SCM proc);
SCM_API int scm_badargsp (SCM formals, SCM args);
SCM_API SCM scm_call_0 (SCM proc);
SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
-SCM_INTERNAL SCM scm_i_call_closure_0 (SCM proc);
-SCM_API scm_t_trampoline_0 scm_trampoline_0 (SCM proc);
-SCM_API scm_t_trampoline_1 scm_trampoline_1 (SCM proc);
-SCM_API scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
SCM_API SCM scm_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
-SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args);
+#define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args)
SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
-SCM_API SCM scm_closure (SCM code, SCM env);
-SCM_API SCM scm_make_promise (SCM thunk);
-SCM_API SCM scm_force (SCM x);
-SCM_API SCM scm_promise_p (SCM x);
-SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);
-SCM_API SCM scm_copy_tree (SCM obj);
-SCM_API SCM scm_i_eval_x (SCM exp, SCM env) /* not internal */;
-SCM_INTERNAL SCM scm_i_eval (SCM exp, SCM env);
SCM_API SCM scm_primitive_eval (SCM exp);
-SCM_API SCM scm_primitive_eval_x (SCM exp);
+#define scm_primitive_eval_x(exp) scm_primitive_eval (exp)
SCM_API SCM scm_eval (SCM exp, SCM module);
-SCM_API SCM scm_eval_x (SCM exp, SCM module);
+#define scm_eval_x(exp, module) scm_eval (exp, module)
-SCM_INTERNAL void scm_i_print_iloc (SCM /*iloc*/, SCM /*port*/);
-SCM_INTERNAL void scm_i_print_isym (SCM /*isym*/, SCM /*port*/);
-SCM_INTERNAL SCM scm_i_unmemocopy_expr (SCM expr, SCM env);
-SCM_INTERNAL SCM scm_i_unmemocopy_body (SCM forms, SCM env);
SCM_INTERNAL void scm_init_eval (void);
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-/* Deprecated in guile 1.7.0 on 2004-03-29. */
-SCM_API SCM scm_ceval (SCM x, SCM env);
-SCM_API SCM scm_deval (SCM x, SCM env);
-SCM_API SCM (*scm_ceval_ptr) (SCM x, SCM env);
-
-#endif
-
-
#endif /* SCM_EVAL_H */
/*
+++ /dev/null
-/*
- * eval.i.c - actual evaluator code for GUILE
- *
- * Copyright (C) 2002, 03, 04, 05, 06, 07, 09 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
- */
-
-#undef RETURN
-#undef ENTER_APPLY
-#undef PREP_APPLY
-#undef CEVAL
-#undef SCM_APPLY
-#undef EVAL_DEBUGGING_P
-
-
-#ifdef DEVAL
-
-/*
- This code is specific for the debugging support.
- */
-
-#define EVAL_DEBUGGING_P 1
-#define CEVAL deval /* Substitute all uses of ceval */
-#define SCM_APPLY scm_dapply
-#define PREP_APPLY(p, l) \
-{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
-
-#define ENTER_APPLY \
-do { \
- SCM_SET_ARGSREADY (debug);\
- if (scm_check_apply_p && SCM_TRAPS_P)\
- if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
- {\
- SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
- SCM_SET_TRACED_FRAME (debug); \
- SCM_TRAPS_P = 0;\
- tmp = scm_make_debugobj (&debug);\
- scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
- SCM_TRAPS_P = 1;\
- }\
-} while (0)
-
-#define RETURN(e) do { proc = (e); goto exit; } while (0)
-
-#ifdef STACK_CHECKING
-# ifndef EVAL_STACK_CHECKING
-# define EVAL_STACK_CHECKING
-# endif /* EVAL_STACK_CHECKING */
-#endif /* STACK_CHECKING */
-
-
-
-
-static SCM
-deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
-{
- SCM *results = lloc;
- while (scm_is_pair (l))
- {
- const SCM res = SCM_I_XEVALCAR (l, env, 1);
-
- *lloc = scm_list_1 (res);
- lloc = SCM_CDRLOC (*lloc);
- l = SCM_CDR (l);
- }
- if (!scm_is_null (l))
- scm_wrong_num_args (proc);
- return *results;
-}
-
-
-#else /* DEVAL */
-
-/*
- Code is specific to debugging-less support.
- */
-
-
-#define CEVAL ceval
-#define SCM_APPLY scm_apply
-#define PREP_APPLY(proc, args)
-#define ENTER_APPLY
-#define RETURN(x) do { return x; } while (0)
-#define EVAL_DEBUGGING_P 0
-
-#ifdef STACK_CHECKING
-# ifndef NO_CEVAL_STACK_CHECKING
-# define EVAL_STACK_CHECKING
-# endif
-#endif
-
-
-
-
-static void
-ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
-{
- SCM argv[10];
- int i = 0, imax = sizeof (argv) / sizeof (SCM);
-
- while (!scm_is_null (init_forms))
- {
- if (imax == i)
- {
- ceval_letrec_inits (env, init_forms, init_values_eol);
- break;
- }
- argv[i++] = SCM_I_XEVALCAR (init_forms, env, 0);
- init_forms = SCM_CDR (init_forms);
- }
-
- for (i--; i >= 0; i--)
- {
- **init_values_eol = scm_list_1 (argv[i]);
- *init_values_eol = SCM_CDRLOC (**init_values_eol);
- }
-}
-
-static SCM
-scm_ceval_args (SCM l, SCM env, SCM proc)
-{
- SCM results = SCM_EOL, *lloc = &results, res;
- while (scm_is_pair (l))
- {
- res = EVALCAR (l, env);
-
- *lloc = scm_list_1 (res);
- lloc = SCM_CDRLOC (*lloc);
- l = SCM_CDR (l);
- }
- if (!scm_is_null (l))
- scm_wrong_num_args (proc);
- return results;
-}
-
-
-SCM
-scm_eval_args (SCM l, SCM env, SCM proc)
-{
- return scm_ceval_args (l, env, proc);
-}
-
-
-
-#endif
-
-
-
-
-#define EVAL(x, env) SCM_I_XEVAL(x, env, EVAL_DEBUGGING_P)
-#define EVALCAR(x, env) SCM_I_XEVALCAR(x, env, EVAL_DEBUGGING_P)
-
-
-
-/* Update the toplevel environment frame ENV so that it refers to the
- * current module. */
-#define UPDATE_TOPLEVEL_ENV(env) \
- do { \
- SCM p = scm_current_module_lookup_closure (); \
- if (p != SCM_CAR (env)) \
- env = scm_top_level_env (p); \
- } while (0)
-
-
-#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
- ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
-
-
-/* This is the evaluator. Like any real monster, it has three heads:
- *
- * ceval is the non-debugging evaluator, deval is the debugging version. Both
- * are implemented using a common code base, using the following mechanism:
- * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
- * is no function CEVAL, but the code for CEVAL actually compiles to either
- * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
- * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
- * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
- * are enclosed within #ifdef DEVAL ... #endif.
- *
- * All three (ceval, deval and their common implementation CEVAL) take two
- * input parameters, x and env: x is a single expression to be evalutated.
- * env is the environment in which bindings are searched.
- *
- * x is known to be a pair. Since x is a single expression, it is necessarily
- * in a tail position. If x is just a call to another function like in the
- * expression (foo exp1 exp2 ...), the realization of that call therefore
- * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
- * however, may do so). This is realized by making extensive use of 'goto'
- * statements within the evaluator: The gotos replace recursive calls to
- * CEVAL, thus re-using the same stack frame that CEVAL was already using.
- * If, however, x represents some form that requires to evaluate a sequence of
- * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
- * performed for all but the last expression of that sequence. */
-
-static SCM
-CEVAL (SCM x, SCM env)
-{
- SCM proc, arg1;
-#ifdef DEVAL
- scm_t_debug_frame debug;
- scm_t_debug_info *debug_info_end;
- debug.prev = scm_i_last_debug_frame ();
- debug.status = 0;
- /*
- * The debug.vect contains twice as much scm_t_debug_info frames as the
- * user has specified with (debug-set! frames <n>).
- *
- * Even frames are eval frames, odd frames are apply frames.
- */
- debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
- * sizeof (scm_t_debug_info));
- debug.info = debug.vect;
- debug_info_end = debug.vect + scm_debug_eframe_size;
- scm_i_set_last_debug_frame (&debug);
-#endif
-#ifdef EVAL_STACK_CHECKING
- if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
- {
-#ifdef DEVAL
- debug.info->e.exp = x;
- debug.info->e.env = env;
-#endif
- scm_report_stack_overflow ();
- }
-#endif
-
-#ifdef DEVAL
- goto start;
-#endif
-
-loop:
-#ifdef DEVAL
- SCM_CLEAR_ARGSREADY (debug);
- if (SCM_OVERFLOWP (debug))
- --debug.info;
- /*
- * In theory, this should be the only place where it is necessary to
- * check for space in debug.vect since both eval frames and
- * available space are even.
- *
- * For this to be the case, however, it is necessary that primitive
- * special forms which jump back to `loop', `begin' or some similar
- * label call PREP_APPLY.
- */
- else if (++debug.info >= debug_info_end)
- {
- SCM_SET_OVERFLOW (debug);
- debug.info -= 2;
- }
-
-start:
- debug.info->e.exp = x;
- debug.info->e.env = env;
- if (scm_check_entry_p && SCM_TRAPS_P)
- {
- if (SCM_ENTER_FRAME_P
- || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
- {
- SCM stackrep;
- SCM tail = scm_from_bool (SCM_TAILRECP (debug));
- SCM_SET_TAILREC (debug);
- stackrep = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR,
- scm_sym_enter_frame,
- stackrep,
- tail,
- unmemoize_expression (x, env));
- SCM_TRAPS_P = 1;
- if (scm_is_pair (stackrep) &&
- scm_is_eq (SCM_CAR (stackrep), sym_instead))
- {
- /* This gives the possibility for the debugger to modify
- the source expression before evaluation. */
- x = SCM_CDR (stackrep);
- if (SCM_IMP (x))
- RETURN (x);
- }
- }
- }
-#endif
-dispatch:
- SCM_TICK;
- if (SCM_ISYMP (SCM_CAR (x)))
- {
- switch (ISYMNUM (SCM_CAR (x)))
- {
- case (ISYMNUM (SCM_IM_AND)):
- x = SCM_CDR (x);
- while (!scm_is_null (SCM_CDR (x)))
- {
- SCM test_result = EVALCAR (x, env);
- if (scm_is_false (test_result) || SCM_NILP (test_result))
- RETURN (SCM_BOOL_F);
- else
- x = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
- case (ISYMNUM (SCM_IM_BEGIN)):
- x = SCM_CDR (x);
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
-
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
-
- begin:
- /* If we are on toplevel with a lookup closure, we need to sync
- with the current module. */
- if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env)))
- {
- UPDATE_TOPLEVEL_ENV (env);
- while (!scm_is_null (SCM_CDR (x)))
- {
- EVALCAR (x, env);
- UPDATE_TOPLEVEL_ENV (env);
- x = SCM_CDR (x);
- }
- goto carloop;
- }
- else
- goto nontoplevel_begin;
-
- nontoplevel_begin:
- while (!scm_is_null (SCM_CDR (x)))
- {
- const SCM form = SCM_CAR (x);
- if (SCM_IMP (form))
- {
- if (SCM_ISYMP (form))
- {
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (x)))
- m_expand_body (x, env);
- scm_dynwind_end ();
- goto nontoplevel_begin;
- }
- else
- SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
- }
- else
- (void) EVAL (form, env);
- x = SCM_CDR (x);
- }
-
- carloop:
- {
- /* scm_eval last form in list */
- const SCM last_form = SCM_CAR (x);
-
- if (scm_is_pair (last_form))
- {
- /* This is by far the most frequent case. */
- x = last_form;
- goto loop; /* tail recurse */
- }
- else if (SCM_IMP (last_form))
- RETURN (SCM_I_EVALIM (last_form, env));
- else if (SCM_VARIABLEP (last_form))
- RETURN (SCM_VARIABLE_REF (last_form));
- else if (scm_is_symbol (last_form))
- RETURN (*scm_lookupcar (x, env, 1));
- else
- RETURN (last_form);
- }
-
-
- case (ISYMNUM (SCM_IM_CASE)):
- x = SCM_CDR (x);
- {
- const SCM key = EVALCAR (x, env);
- x = SCM_CDR (x);
- while (!scm_is_null (x))
- {
- const SCM clause = SCM_CAR (x);
- SCM labels = SCM_CAR (clause);
- if (scm_is_eq (labels, SCM_IM_ELSE))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- while (!scm_is_null (labels))
- {
- const SCM label = SCM_CAR (labels);
- if (scm_is_eq (label, key)
- || scm_is_true (scm_eqv_p (label, key)))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- labels = SCM_CDR (labels);
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_COND)):
- x = SCM_CDR (x);
- while (!scm_is_null (x))
- {
- const SCM clause = SCM_CAR (x);
- if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- arg1 = EVALCAR (clause, env);
- /* SRFI 61 extended cond */
- if (!scm_is_null (SCM_CDR (clause))
- && !scm_is_null (SCM_CDDR (clause))
- && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
- {
- SCM xx, guard_result;
- if (SCM_VALUESP (arg1))
- arg1 = scm_struct_ref (arg1, SCM_INUM0);
- else
- arg1 = scm_list_1 (arg1);
- xx = SCM_CDR (clause);
- proc = EVALCAR (xx, env);
- guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
- if (scm_is_true (guard_result)
- && !SCM_NILP (guard_result))
- {
- proc = SCM_CDDR (xx);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
- }
- else if (scm_is_true (arg1) && !SCM_NILP (arg1))
- {
- x = SCM_CDR (clause);
- if (scm_is_null (x))
- RETURN (arg1);
- else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
- {
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- proc = SCM_CDR (x);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, scm_list_1 (arg1));
- ENTER_APPLY;
- goto evap1;
- }
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_DO)):
- x = SCM_CDR (x);
- {
- /* Compute the initialization values and the initial environment. */
- SCM init_forms = SCM_CAR (x);
- SCM init_values = SCM_EOL;
- while (!scm_is_null (init_forms))
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- x = SCM_CDR (x);
- env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
- }
- x = SCM_CDR (x);
- {
- SCM test_form = SCM_CAR (x);
- SCM body_forms = SCM_CADR (x);
- SCM step_forms = SCM_CDDR (x);
-
- SCM test_result = EVALCAR (test_form, env);
-
- while (scm_is_false (test_result) || SCM_NILP (test_result))
- {
- {
- /* Evaluate body forms. */
- SCM temp_forms;
- for (temp_forms = body_forms;
- !scm_is_null (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- SCM form = SCM_CAR (temp_forms);
- /* Dirk:FIXME: We only need to eval forms that may have
- * a side effect here. This is only true for forms that
- * start with a pair. All others are just constants.
- * Since with the current memoizer 'form' may hold a
- * constant, we call EVAL here to handle the constant
- * cases. In the long run it would make sense to have
- * the macro transformer of 'do' eliminate all forms
- * that have no sideeffect. Then instead of EVAL we
- * could call CEVAL directly here. */
- (void) EVAL (form, env);
- }
- }
-
- {
- /* Evaluate the step expressions. */
- SCM temp_forms;
- SCM step_values = SCM_EOL;
- for (temp_forms = step_forms;
- !scm_is_null (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- const SCM value = EVALCAR (temp_forms, env);
- step_values = scm_cons (value, step_values);
- }
- env = SCM_EXTEND_ENV (SCM_CAAR (env),
- step_values,
- SCM_CDR (env));
- }
-
- test_result = EVALCAR (test_form, env);
- }
- }
- x = SCM_CDAR (x);
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_IF)):
- x = SCM_CDR (x);
- {
- SCM test_result = EVALCAR (x, env);
- x = SCM_CDR (x); /* then expression */
- if (scm_is_false (test_result) || SCM_NILP (test_result))
- {
- x = SCM_CDR (x); /* else expression */
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
- }
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
-
- case (ISYMNUM (SCM_IM_LET)):
- x = SCM_CDR (x);
- {
- SCM init_forms = SCM_CADR (x);
- SCM init_values = SCM_EOL;
- do
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- while (!scm_is_null (init_forms));
- env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
- }
- x = SCM_CDDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_LETREC)):
- x = SCM_CDR (x);
- env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
- x = SCM_CDR (x);
- {
- SCM init_forms = SCM_CAR (x);
- SCM init_values = scm_list_1 (SCM_BOOL_T);
- SCM *init_values_eol = SCM_CDRLOC (init_values);
- ceval_letrec_inits (env, init_forms, &init_values_eol);
- SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_LETSTAR)):
- x = SCM_CDR (x);
- {
- SCM bindings = SCM_CAR (x);
- if (!scm_is_null (bindings))
- {
- do
- {
- SCM name = SCM_CAR (bindings);
- SCM init = SCM_CDR (bindings);
- env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
- bindings = SCM_CDR (init);
- }
- while (!scm_is_null (bindings));
- }
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_OR)):
- x = SCM_CDR (x);
- while (!scm_is_null (SCM_CDR (x)))
- {
- SCM val = EVALCAR (x, env);
- if (scm_is_true (val) && !SCM_NILP (val))
- RETURN (val);
- else
- x = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
-
- case (ISYMNUM (SCM_IM_LAMBDA)):
- RETURN (scm_closure (SCM_CDR (x), env));
-
-
- case (ISYMNUM (SCM_IM_QUOTE)):
- RETURN (SCM_CDR (x));
-
-
- case (ISYMNUM (SCM_IM_SET_X)):
- x = SCM_CDR (x);
- {
- SCM *location;
- SCM variable = SCM_CAR (x);
- if (SCM_ILOCP (variable))
- location = scm_ilookup (variable, env);
- else if (SCM_VARIABLEP (variable))
- location = SCM_VARIABLE_LOC (variable);
- else
- {
- /* (scm_is_symbol (variable)) is known to be true */
- variable = lazy_memoize_variable (variable, env);
- SCM_SETCAR (x, variable);
- location = SCM_VARIABLE_LOC (variable);
- }
- x = SCM_CDR (x);
- *location = EVALCAR (x, env);
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_APPLY)):
- /* Evaluate the procedure to be applied. */
- x = SCM_CDR (x);
- proc = EVALCAR (x, env);
- PREP_APPLY (proc, SCM_EOL);
-
- /* Evaluate the argument holding the list of arguments */
- x = SCM_CDR (x);
- arg1 = EVALCAR (x, env);
-
- apply_proc:
- /* Go here to tail-apply a procedure. PROC is the procedure and
- * ARG1 is the list of arguments. PREP_APPLY must have been called
- * before jumping to apply_proc. */
- if (SCM_CLOSUREP (proc))
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
-#ifdef DEVAL
- debug.info->a.args = arg1;
-#endif
- if (SCM_UNLIKELY (scm_badargsp (formals, arg1)))
- scm_wrong_num_args (proc);
- ENTER_APPLY;
- /* Copy argument list */
- if (SCM_NULL_OR_NIL_P (arg1))
- env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
- else
- {
- SCM args = scm_list_1 (SCM_CAR (arg1));
- SCM tail = args;
- arg1 = SCM_CDR (arg1);
- while (!SCM_NULL_OR_NIL_P (arg1))
- {
- SCM new_tail = scm_list_1 (SCM_CAR (arg1));
- SCM_SETCDR (tail, new_tail);
- tail = new_tail;
- arg1 = SCM_CDR (arg1);
- }
- env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
- }
-
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
- else
- {
- ENTER_APPLY;
- RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
- }
-
-
- case (ISYMNUM (SCM_IM_CONT)):
- {
- int first;
- SCM val = scm_make_continuation (&first);
-
- if (!first)
- RETURN (val);
- else
- {
- arg1 = val;
- proc = SCM_CDR (x);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, scm_list_1 (arg1));
- ENTER_APPLY;
- goto evap1;
- }
- }
-
-
- case (ISYMNUM (SCM_IM_DELAY)):
- RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env)));
-
-#if 0
- /* See futures.h for a comment why futures are not enabled.
- */
- case (ISYMNUM (SCM_IM_FUTURE)):
- RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
-#endif
-
- /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
- code (type_dispatch) is intended to be the tail of the case
- clause for the internal macro SCM_IM_DISPATCH. Please don't
- remove it from this location without discussing it with Mikael
- <djurfeldt@nada.kth.se> */
-
- /* The type dispatch code is duplicated below
- * (c.f. objects.c:scm_mcache_compute_cmethod) since that
- * cuts down execution time for type dispatch to 50%. */
- type_dispatch: /* inputs: x, arg1 */
- /* Type dispatch means to determine from the types of the function
- * arguments (i. e. the 'signature' of the call), which method from
- * a generic function is to be called. This process of selecting
- * the right method takes some time. To speed it up, guile uses
- * caching: Together with the macro call to dispatch the signatures
- * of some previous calls to that generic function from the same
- * place are stored (in the code!) in a cache that we call the
- * 'method cache'. This is done since it is likely, that
- * consecutive calls to dispatch from that position in the code will
- * have the same signature. Thus, the type dispatch works as
- * follows: First, determine a hash value from the signature of the
- * actual arguments. Second, use this hash value as an index to
- * find that same signature in the method cache stored at this
- * position in the code. If found, you have also found the
- * corresponding method that belongs to that signature. If the
- * signature is not found in the method cache, you have to perform a
- * full search over all signatures stored with the generic
- * function. */
- {
- unsigned long int specializers;
- unsigned long int hash_value;
- unsigned long int cache_end_pos;
- unsigned long int mask;
- SCM method_cache;
-
- {
- SCM z = SCM_CDDR (x);
- SCM tmp = SCM_CADR (z);
- specializers = scm_to_ulong (SCM_CAR (z));
-
- /* Compute a hash value for searching the method cache. There
- * are two variants for computing the hash value, a (rather)
- * complicated one, and a simple one. For the complicated one
- * explained below, tmp holds a number that is used in the
- * computation. */
- if (scm_is_simple_vector (tmp))
- {
- /* This method of determining the hash value is much
- * simpler: Set the hash value to zero and just perform a
- * linear search through the method cache. */
- method_cache = tmp;
- mask = (unsigned long int) ((long) -1);
- hash_value = 0;
- cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache);
- }
- else
- {
- /* Use the signature of the actual arguments to determine
- * the hash value. This is done as follows: Each class has
- * an array of random numbers, that are determined when the
- * class is created. The integer 'hashset' is an index into
- * that array of random numbers. Now, from all classes that
- * are part of the signature of the actual arguments, the
- * random numbers at index 'hashset' are taken and summed
- * up, giving the hash value. The value of 'hashset' is
- * stored at the call to dispatch. This allows to have
- * different 'formulas' for calculating the hash value at
- * different places where dispatch is called. This allows
- * to optimize the hash formula at every individual place
- * where dispatch is called, such that hopefully the hash
- * value that is computed will directly point to the right
- * method in the method cache. */
- unsigned long int hashset = scm_to_ulong (tmp);
- unsigned long int counter = specializers + 1;
- SCM tmp_arg = arg1;
- hash_value = 0;
- while (!scm_is_null (tmp_arg) && counter != 0)
- {
- SCM class = scm_class_of (SCM_CAR (tmp_arg));
- hash_value += SCM_INSTANCE_HASH (class, hashset);
- tmp_arg = SCM_CDR (tmp_arg);
- counter--;
- }
- z = SCM_CDDR (z);
- method_cache = SCM_CADR (z);
- mask = scm_to_ulong (SCM_CAR (z));
- hash_value &= mask;
- cache_end_pos = hash_value;
- }
- }
-
- {
- /* Search the method cache for a method with a matching
- * signature. Start the search at position 'hash_value'. The
- * hashing implementation uses linear probing for conflict
- * resolution, that is, if the signature in question is not
- * found at the starting index in the hash table, the next table
- * entry is tried, and so on, until in the worst case the whole
- * cache has been searched, but still the signature has not been
- * found. */
- SCM z;
- do
- {
- SCM args = arg1; /* list of arguments */
- z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value);
- while (!scm_is_null (args))
- {
- /* More arguments than specifiers => CLASS != ENV */
- SCM class_of_arg = scm_class_of (SCM_CAR (args));
- if (!scm_is_eq (class_of_arg, SCM_CAR (z)))
- goto next_method;
- args = SCM_CDR (args);
- z = SCM_CDR (z);
- }
- /* Fewer arguments than specifiers => CAR != CLASS */
- if (!scm_is_pair (z))
- goto apply_vm_cmethod;
- else if (!SCM_CLASSP (SCM_CAR (z))
- && !scm_is_symbol (SCM_CAR (z)))
- goto apply_memoized_cmethod;
- next_method:
- hash_value = (hash_value + 1) & mask;
- } while (hash_value != cache_end_pos);
-
- /* No appropriate method was found in the cache. */
- z = scm_memoize_method (x, arg1);
-
- if (scm_is_pair (z))
- goto apply_memoized_cmethod;
-
- apply_vm_cmethod:
- proc = z;
- PREP_APPLY (proc, arg1);
- goto apply_proc;
-
- apply_memoized_cmethod: /* inputs: z, arg1 */
- {
- SCM formals = SCM_CMETHOD_FORMALS (z);
- env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
- x = SCM_CMETHOD_BODY (z);
- goto nontoplevel_begin;
- }
- }
- }
-
-
- case (ISYMNUM (SCM_IM_SLOT_REF)):
- x = SCM_CDR (x);
- {
- SCM instance = EVALCAR (x, env);
- unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
- RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
- }
-
-
- case (ISYMNUM (SCM_IM_SLOT_SET_X)):
- x = SCM_CDR (x);
- {
- SCM instance = EVALCAR (x, env);
- unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
- SCM value = EVALCAR (SCM_CDDR (x), env);
- SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
- RETURN (SCM_UNSPECIFIED);
- }
-
-
-#if SCM_ENABLE_ELISP
-
- case (ISYMNUM (SCM_IM_NIL_COND)):
- {
- SCM test_form = SCM_CDR (x);
- x = SCM_CDR (test_form);
- while (!SCM_NULL_OR_NIL_P (x))
- {
- SCM test_result = EVALCAR (test_form, env);
- if (!(scm_is_false (test_result)
- || SCM_NULL_OR_NIL_P (test_result)))
- {
- if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
- RETURN (test_result);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
- else
- {
- test_form = SCM_CDR (x);
- x = SCM_CDR (test_form);
- }
- }
- x = test_form;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
-
-#endif /* SCM_ENABLE_ELISP */
-
- case (ISYMNUM (SCM_IM_BIND)):
- {
- SCM vars, exps, vals;
-
- x = SCM_CDR (x);
- vars = SCM_CAAR (x);
- exps = SCM_CDAR (x);
- vals = SCM_EOL;
- while (!scm_is_null (exps))
- {
- vals = scm_cons (EVALCAR (exps, env), vals);
- exps = SCM_CDR (exps);
- }
-
- scm_swap_bindings (vars, vals);
- scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
-
- /* Ignore all but the last evaluation result. */
- for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
- {
- if (scm_is_pair (SCM_CAR (x)))
- CEVAL (SCM_CAR (x), env);
- }
- proc = EVALCAR (x, env);
-
- scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
- scm_swap_bindings (vars, vals);
-
- RETURN (proc);
- }
-
-
- case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
- {
- SCM producer;
-
- x = SCM_CDR (x);
- producer = EVALCAR (x, env);
- x = SCM_CDR (x);
- proc = EVALCAR (x, env); /* proc is the consumer. */
- arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
- if (SCM_VALUESP (arg1))
- {
- /* The list of arguments is not copied. Rather, it is assumed
- * that this has been done by the 'values' procedure. */
- arg1 = scm_struct_ref (arg1, SCM_INUM0);
- }
- else
- {
- arg1 = scm_list_1 (arg1);
- }
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
-
-
- default:
- break;
- }
- }
- else
- {
- if (SCM_VARIABLEP (SCM_CAR (x)))
- proc = SCM_VARIABLE_REF (SCM_CAR (x));
- else if (SCM_ILOCP (SCM_CAR (x)))
- proc = *scm_ilookup (SCM_CAR (x), env);
- else if (scm_is_pair (SCM_CAR (x)))
- proc = CEVAL (SCM_CAR (x), env);
- else if (scm_is_symbol (SCM_CAR (x)))
- {
- SCM orig_sym = SCM_CAR (x);
- {
- SCM *location = scm_lookupcar1 (x, env, 1);
- if (location == NULL)
- {
- /* we have lost the race, start again. */
- goto dispatch;
- }
- proc = *location;
-#ifdef DEVAL
- if (scm_check_memoize_p && SCM_TRAPS_P)
- {
- SCM_CLEAR_TRACED_FRAME (debug);
- SCM arg1 = scm_make_debugobj (&debug);
- SCM retval = SCM_BOOL_T;
- SCM_TRAPS_P = 0;
- retval = scm_call_4 (SCM_MEMOIZE_HDLR,
- scm_sym_memoize_symbol,
- arg1, x, env);
-
- /*
- do something with retval?
- */
- SCM_TRAPS_P = 1;
- }
-#endif
- }
-
- if (SCM_MACROP (proc))
- {
- SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
- lookupcar */
- handle_a_macro: /* inputs: x, env, proc */
-#ifdef DEVAL
- /* Set a flag during macro expansion so that macro
- application frames can be deleted from the backtrace. */
- SCM_SET_MACROEXP (debug);
-#endif
- arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
- scm_cons (env, scm_listofnull));
-#ifdef DEVAL
- SCM_CLEAR_MACROEXP (debug);
-#endif
- switch (SCM_MACRO_TYPE (proc))
- {
- case 3:
- case 2:
- if (!scm_is_pair (arg1))
- arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
-
- assert (!scm_is_eq (x, SCM_CAR (arg1))
- && !scm_is_eq (x, SCM_CDR (arg1)));
-
-#ifdef DEVAL
- if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
- {
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (arg1));
- SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_CRITICAL_SECTION_END;
- goto dispatch;
- }
- /* Prevent memoizing of debug info expression. */
- debug.info->e.exp = scm_cons_source (debug.info->e.exp,
- SCM_CAR (x),
- SCM_CDR (x));
-#endif
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (arg1));
- SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_CRITICAL_SECTION_END;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto loop;
-#if SCM_ENABLE_DEPRECATED == 1
- case 1:
- x = arg1;
- if (SCM_NIMP (x))
- {
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto loop;
- }
- else
- RETURN (arg1);
-#endif
- case 0:
- RETURN (arg1);
- }
- }
- }
- else
- proc = SCM_CAR (x);
-
- if (SCM_MACROP (proc))
- goto handle_a_macro;
- }
-
-
- /* When reaching this part of the code, the following is granted: Variable x
- * holds the first pair of an expression of the form (<function> arg ...).
- * Variable proc holds the object that resulted from the evaluation of
- * <function>. In the following, the arguments (if any) will be evaluated,
- * and proc will be applied to them. If proc does not really hold a
- * function object, this will be signalled as an error on the scheme
- * level. If the number of arguments does not match the number of arguments
- * that are allowed to be passed to proc, also an error on the scheme level
- * will be signalled. */
-
- PREP_APPLY (proc, SCM_EOL);
- if (scm_is_null (SCM_CDR (x))) {
- ENTER_APPLY;
- evap0:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* no arguments given */
- case scm_tc7_subr_0:
- RETURN (SCM_SUBRF (proc) ());
- case scm_tc7_subr_1o:
- RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (SCM_EOL));
- case scm_tc7_rpsubr:
- RETURN (SCM_BOOL_T);
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
- case scm_tc7_program:
- RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_0 (proc));
- case scm_tc7_gsubr:
-#ifdef DEVAL
- debug.info->a.proc = proc;
- debug.info->a.args = SCM_EOL;
-#endif
- RETURN (scm_i_gsubr_apply (proc, SCM_UNDEFINED));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
-#endif
- if (!SCM_CLOSUREP (proc))
- goto evap0;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (SCM_UNLIKELY (scm_is_pair (formals)))
- goto wrongnumargs;
- x = SCM_CLOSURE_BODY (proc);
- env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
- goto nontoplevel_begin;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
- arg1 = SCM_EOL;
- goto type_dispatch;
- }
- else if (SCM_I_OPERATORP (proc))
- {
- arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
-#ifdef DEVAL
- debug.info->a.proc = proc;
- debug.info->a.args = scm_list_1 (arg1);
-#endif
- goto evap1;
- }
- else
- goto badfun;
- case scm_tc7_subr_1:
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- wrongnumargs:
- scm_wrong_num_args (proc);
- default:
- badfun:
- scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
- }
- }
-
- /* must handle macros by here */
- x = SCM_CDR (x);
- if (SCM_LIKELY (scm_is_pair (x)))
- arg1 = EVALCAR (x, env);
- else
- scm_wrong_num_args (proc);
-#ifdef DEVAL
- debug.info->a.args = scm_list_1 (arg1);
-#endif
- x = SCM_CDR (x);
- {
- SCM arg2;
- if (scm_is_null (x))
- {
- ENTER_APPLY;
- evap1: /* inputs: proc, arg1 */
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have one argument in arg1 */
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- case scm_tc7_subr_1:
- case scm_tc7_subr_1o:
- RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_dsubr:
- if (SCM_I_INUMP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
- else if (SCM_BIGP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
- else if (SCM_FRACTIONP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
- }
- SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
- case scm_tc7_cxr:
- RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
- case scm_tc7_rpsubr:
- RETURN (SCM_BOOL_T);
- case scm_tc7_program:
- RETURN (scm_c_vm_run (scm_the_vm (), proc, &arg1, 1));
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- case scm_tc7_lsubr:
-#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
-#else
- RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
-#endif
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
- case scm_tc7_gsubr:
-#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
- debug.info->a.proc = proc;
-#endif
- RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
-#endif
- if (!SCM_CLOSUREP (proc))
- goto evap1;
- /* fallthrough */
- case scm_tcs_closures:
- {
- /* clos1: */
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals))))
- goto wrongnumargs;
- x = SCM_CLOSURE_BODY (proc);
-#ifdef DEVAL
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
-#else
- env = SCM_EXTEND_ENV (formals,
- scm_list_1 (arg1),
- SCM_ENV (proc));
-#endif
- goto nontoplevel_begin;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_1 (arg1);
-#endif
- goto type_dispatch;
- }
- else if (SCM_I_OPERATORP (proc))
- {
- arg2 = arg1;
- arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
-#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
- debug.info->a.proc = proc;
-#endif
- goto evap2;
- }
- else
- goto badfun;
- case scm_tc7_subr_2:
- case scm_tc7_subr_0:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- }
- }
- if (SCM_LIKELY (scm_is_pair (x)))
- arg2 = EVALCAR (x, env);
- else
- scm_wrong_num_args (proc);
-
- { /* have two or more arguments */
-#ifdef DEVAL
- debug.info->a.args = scm_list_2 (arg1, arg2);
-#endif
- x = SCM_CDR (x);
- if (scm_is_null (x)) {
- ENTER_APPLY;
- evap2:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have two arguments */
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (arg1, arg2));
- case scm_tc7_lsubr:
-#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
-#else
- RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
-#endif
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (arg1, arg2));
- case scm_tc7_program:
- { SCM args[2];
- args[0] = arg1;
- args[1] = arg2;
- RETURN (scm_c_vm_run (scm_the_vm (), proc, args, 2));
- }
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
- case scm_tc7_gsubr:
-#ifdef DEVAL
- RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
-#else
- RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
-#endif
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_2 (arg1, arg2);
-#endif
- goto type_dispatch;
- }
- else if (SCM_I_OPERATORP (proc))
- {
- operatorn:
-#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc),
- scm_cons (proc, debug.info->a.args),
- SCM_EOL));
-#else
- RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc),
- scm_cons2 (proc, arg1,
- scm_cons (arg2,
- scm_ceval_args (x,
- env,
- proc))),
- SCM_EOL));
-#endif
- }
- else
- goto badfun;
- case scm_tc7_subr_0:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_1:
- case scm_tc7_subr_3:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
-#endif
- if (!SCM_CLOSUREP (proc))
- goto evap2;
- /* fallthrough */
- case scm_tcs_closures:
- {
- /* clos2: */
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_is_pair (SCM_CDDR (formals))))))
- goto wrongnumargs;
-#ifdef DEVAL
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
-#else
- env = SCM_EXTEND_ENV (formals,
- scm_list_2 (arg1, arg2),
- SCM_ENV (proc));
-#endif
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
- }
- }
- if (SCM_UNLIKELY (!scm_is_pair (x)))
- scm_wrong_num_args (proc);
-#ifdef DEVAL
- debug.info->a.args = scm_cons2 (arg1, arg2,
- deval_args (x, env, proc,
- SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
-#endif
- ENTER_APPLY;
- evap3:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have 3 or more arguments */
-#ifdef DEVAL
- case scm_tc7_subr_3:
- if (!scm_is_null (SCM_CDR (x)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, arg2,
- SCM_CADDR (debug.info->a.args)));
- case scm_tc7_asubr:
- arg1 = SCM_SUBRF(proc)(arg1, arg2);
- arg2 = SCM_CDDR (debug.info->a.args);
- do
- {
- arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
- arg2 = SCM_CDR (arg2);
- }
- while (SCM_NIMP (arg2));
- RETURN (arg1);
- case scm_tc7_rpsubr:
- if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
- RETURN (SCM_BOOL_F);
- arg1 = SCM_CDDR (debug.info->a.args);
- do
- {
- if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
- RETURN (SCM_BOOL_F);
- arg2 = SCM_CAR (arg1);
- arg1 = SCM_CDR (arg1);
- }
- while (SCM_NIMP (arg1));
- RETURN (SCM_BOOL_T);
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2,
- SCM_CDDR (debug.info->a.args)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
- SCM_CDDR (debug.info->a.args)));
- case scm_tc7_gsubr:
- RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
- case scm_tc7_program:
- RETURN (scm_vm_apply (scm_the_vm (), proc, debug.info->a.args));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- debug.info->a.proc = proc;
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_badargsp (SCM_CDDR (formals), x)))))
- goto wrongnumargs;
- SCM_SET_ARGSREADY (debug);
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
-#else /* DEVAL */
- case scm_tc7_subr_3:
- if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
- case scm_tc7_asubr:
- arg1 = SCM_SUBRF (proc) (arg1, arg2);
- do
- {
- arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- }
- while (!scm_is_null (x));
- RETURN (arg1);
- case scm_tc7_rpsubr:
- if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
- RETURN (SCM_BOOL_F);
- do
- {
- arg1 = EVALCAR (x, env);
- if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
- RETURN (SCM_BOOL_F);
- arg2 = arg1;
- x = SCM_CDR (x);
- }
- while (!scm_is_null (x));
- RETURN (SCM_BOOL_T);
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
- arg2,
- scm_ceval_args (x, env, proc))));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
- scm_ceval_args (x, env, proc)));
- case scm_tc7_gsubr:
- if (scm_is_null (SCM_CDR (x)))
- /* 3 arguments */
- RETURN (scm_i_gsubr_apply (proc, arg1, arg2, EVALCAR (x, env),
- SCM_UNDEFINED));
- else
- RETURN (scm_i_gsubr_apply_list (proc,
- scm_cons2 (arg1, arg2,
- scm_ceval_args (x, env,
- proc))));
- case scm_tc7_program:
- RETURN (scm_vm_apply
- (scm_the_vm (), proc,
- scm_cons (arg1, scm_cons (arg2,
- scm_ceval_args (x, env, proc)))));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_badargsp (SCM_CDDR (formals), x)))))
- goto wrongnumargs;
- env = SCM_EXTEND_ENV (formals,
- scm_cons2 (arg1,
- arg2,
- scm_ceval_args (x, env, proc)),
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
-#endif /* DEVAL */
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc));
-#endif
- x = SCM_ENTITY_PROCEDURE (proc);
- goto type_dispatch;
- }
- else if (SCM_I_OPERATORP (proc))
- goto operatorn;
- else
- goto badfun;
- case scm_tc7_subr_2:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_2o:
- case scm_tc7_subr_0:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_1:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- }
- }
- }
-#ifdef DEVAL
-exit:
- if (scm_check_exit_p && SCM_TRAPS_P)
- if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
- {
- SCM_CLEAR_TRACED_FRAME (debug);
- arg1 = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
- SCM_TRAPS_P = 1;
- if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
- proc = SCM_CDR (arg1);
- }
- scm_i_set_last_debug_frame (debug.prev);
- return proc;
-#endif
-}
-
-
-
-
-/* Apply a function to a list of arguments.
-
- This function is exported to the Scheme level as taking two
- required arguments and a tail argument, as if it were:
- (lambda (proc arg1 . args) ...)
- Thus, if you just have a list of arguments to pass to a procedure,
- pass the list as ARG1, and '() for ARGS. If you have some fixed
- args, pass the first as ARG1, then cons any remaining fixed args
- onto the front of your argument list, and pass that as ARGS. */
-
-SCM
-SCM_APPLY (SCM proc, SCM arg1, SCM args)
-{
-#ifdef DEVAL
- scm_t_debug_frame debug;
- scm_t_debug_info debug_vect_body;
- debug.prev = scm_i_last_debug_frame ();
- debug.status = SCM_APPLYFRAME;
- debug.vect = &debug_vect_body;
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = SCM_EOL;
- scm_i_set_last_debug_frame (&debug);
-#else
- if (scm_debug_mode_p)
- return scm_dapply (proc, arg1, args);
-#endif
-
- SCM_ASRTGO (SCM_NIMP (proc), badproc);
-
- /* If ARGS is the empty list, then we're calling apply with only two
- arguments --- ARG1 is the list of arguments for PROC. Whatever
- the case, futz with things so that ARG1 is the first argument to
- give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
- rest.
-
- Setting the debug apply frame args this way is pretty messy.
- Perhaps we should store arg1 and args directly in the frame as
- received, and let scm_frame_arguments unpack them, because that's
- a relatively rare operation. This works for now; if the Guile
- developer archives are still around, see Mikael's post of
- 11-Apr-97. */
- if (scm_is_null (args))
- {
- if (scm_is_null (arg1))
- {
- arg1 = SCM_UNDEFINED;
-#ifdef DEVAL
- debug.vect[0].a.args = SCM_EOL;
-#endif
- }
- else
- {
-#ifdef DEVAL
- debug.vect[0].a.args = arg1;
-#endif
- args = SCM_CDR (arg1);
- arg1 = SCM_CAR (arg1);
- }
- }
- else
- {
- args = scm_nconc2last (args);
-#ifdef DEVAL
- debug.vect[0].a.args = scm_cons (arg1, args);
-#endif
- }
-#ifdef DEVAL
- if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
- {
- SCM tmp = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
- SCM_TRAPS_P = 1;
- }
- ENTER_APPLY;
-#endif
-tail:
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_2o:
- if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
- scm_wrong_num_args (proc);
- if (scm_is_null (args))
- args = SCM_UNDEFINED;
- else
- {
- if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args))))
- scm_wrong_num_args (proc);
- args = SCM_CAR (args);
- }
- RETURN (SCM_SUBRF (proc) (arg1, args));
- case scm_tc7_subr_2:
- if (SCM_UNLIKELY (scm_is_null (args) ||
- !scm_is_null (SCM_CDR (args))))
- scm_wrong_num_args (proc);
- args = SCM_CAR (args);
- RETURN (SCM_SUBRF (proc) (arg1, args));
- case scm_tc7_subr_0:
- if (SCM_UNLIKELY (!SCM_UNBNDP (arg1)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) ());
- case scm_tc7_subr_1:
- if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
- scm_wrong_num_args (proc);
- case scm_tc7_subr_1o:
- if (SCM_UNLIKELY (!scm_is_null (args)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_dsubr:
- if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
- scm_wrong_num_args (proc);
- if (SCM_I_INUMP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
- else if (SCM_BIGP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
- else if (SCM_FRACTIONP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
- }
- SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
- case scm_tc7_cxr:
- if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
- scm_wrong_num_args (proc);
- RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
- case scm_tc7_subr_3:
- if (SCM_UNLIKELY (scm_is_null (args)
- || scm_is_null (SCM_CDR (args))
- || !scm_is_null (SCM_CDDR (args))))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
- case scm_tc7_lsubr:
-#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
-#else
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
-#endif
- case scm_tc7_lsubr_2:
- if (SCM_UNLIKELY (!scm_is_pair (args)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
- case scm_tc7_asubr:
- if (scm_is_null (args))
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- while (SCM_NIMP (args))
- {
- SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
- arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
- args = SCM_CDR (args);
- }
- RETURN (arg1);
- case scm_tc7_program:
- if (SCM_UNBNDP (arg1))
- RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
- else
- RETURN (scm_vm_apply (scm_the_vm (), proc, scm_cons (arg1, args)));
- case scm_tc7_rpsubr:
- if (scm_is_null (args))
- RETURN (SCM_BOOL_T);
- while (SCM_NIMP (args))
- {
- SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
- if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
- RETURN (SCM_BOOL_F);
- arg1 = SCM_CAR (args);
- args = SCM_CDR (args);
- }
- RETURN (SCM_BOOL_T);
- case scm_tcs_closures:
-#ifdef DEVAL
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
- if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
- scm_wrong_num_args (proc);
-
- /* Copy argument list */
- if (SCM_IMP (arg1))
- args = arg1;
- else
- {
- SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
- for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
- {
- SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
- tl = SCM_CDR (tl);
- }
- SCM_SETCDR (tl, arg1);
- }
-
- args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- args,
- SCM_ENV (proc));
- proc = SCM_CLOSURE_BODY (proc);
- again:
- arg1 = SCM_CDR (proc);
- while (!scm_is_null (arg1))
- {
- if (SCM_IMP (SCM_CAR (proc)))
- {
- if (SCM_ISYMP (SCM_CAR (proc)))
- {
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (proc)))
- m_expand_body (proc, args);
- scm_dynwind_end ();
- goto again;
- }
- else
- SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
- }
- else
- (void) EVAL (SCM_CAR (proc), args);
- proc = arg1;
- arg1 = SCM_CDR (proc);
- }
- RETURN (EVALCAR (proc, args));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badproc;
- if (SCM_UNBNDP (arg1))
- RETURN (SCM_SMOB_APPLY_0 (proc));
- else if (scm_is_null (args))
- RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
- else if (scm_is_null (SCM_CDR (args)))
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
- else
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
- case scm_tc7_gsubr:
-#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = scm_cons (arg1, args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
- RETURN (scm_i_gsubr_apply_list (proc, args));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.vect[0].a.proc = proc;
-#endif
- goto tail;
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
-#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
- RETURN (scm_apply_generic (proc, args));
- }
- else if (SCM_I_OPERATORP (proc))
- {
- /* operator */
-#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
- arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
-#ifdef DEVAL
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = scm_cons (arg1, args);
-#endif
- if (SCM_NIMP (proc))
- goto tail;
- else
- goto badproc;
- }
- else
- goto badproc;
- default:
- badproc:
- scm_wrong_type_arg ("apply", SCM_ARG1, proc);
- }
-#ifdef DEVAL
-exit:
- if (scm_check_exit_p && SCM_TRAPS_P)
- if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
- {
- SCM_CLEAR_TRACED_FRAME (debug);
- arg1 = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
- SCM_TRAPS_P = 1;
- if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
- proc = SCM_CDR (arg1);
- }
- scm_i_set_last_debug_frame (debug.prev);
- return proc;
-#endif
-}
-
case scm_tc3_cons:
switch (SCM_TYP7 (obj))
{
- case scm_tcs_closures:
case scm_tc7_vector:
case scm_tc7_wvect:
+ case scm_tc7_hashtable:
+ case scm_tc7_fluid:
+ case scm_tc7_dynamic_state:
case scm_tc7_number:
case scm_tc7_string:
case scm_tc7_smob:
- case scm_tc7_pws:
case scm_tc7_program:
- case scm_tcs_subrs:
+ case scm_tc7_bytevector:
+ case scm_tc7_gsubr:
case scm_tcs_struct:
return SCM_BOOL_T;
default:
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007, 2009 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
void
scm_init_feature()
{
- progargs_fluid = scm_permanent_object (scm_make_fluid ());
+ progargs_fluid = scm_make_fluid ();
features_var = scm_c_define ("*features*", SCM_EOL);
#ifndef _Windows
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009 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
#endif
#include <alloca.h>
-#include <canonicalize.h>
+#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
if (ds == NULL)
SCM_SYSERROR;
- SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_DIR_FLAG_OPEN, ds);
+ SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
}
#undef FUNC_NAME
somewhere in the smob, or just the dirent size calculated once. */
{
struct dirent_or_dirent64 de; /* just for sizeof */
- DIR *ds = (DIR *) SCM_CELL_WORD_1 (port);
+ DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
size_t namlen;
#ifdef NAME_MAX
char buf [SCM_MAX (sizeof (de),
scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
errno = 0;
- SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_CELL_WORD_1 (port)));
+ SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port)));
if (errno != 0)
SCM_SYSERROR;
if (!SCM_DIR_OPEN_P (port))
SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
- rewinddir ((DIR *) SCM_CELL_WORD_1 (port));
+ rewinddir ((DIR *) SCM_SMOB_DATA_1 (port));
return SCM_UNSPECIFIED;
}
{
int sts;
- SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port)));
+ SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
if (sts != 0)
SCM_SYSERROR;
- SCM_SET_CELL_WORD_0 (port, scm_tc16_dir);
+ SCM_SET_SMOB_DATA_0 (port, scm_tc16_dir);
}
return SCM_UNSPECIFIED;
if (!SCM_DIR_OPEN_P (exp))
scm_puts ("closed: ", port);
scm_puts ("directory stream ", port);
- scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
+ scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
scm_putc ('>', port);
return 1;
}
scm_dir_free (SCM p)
{
if (SCM_DIR_OPEN_P (p))
- closedir ((DIR *) SCM_CELL_WORD_1 (p));
+ closedir ((DIR *) SCM_SMOB_DATA_1 (p));
return 0;
}
scm_set_smob_free (scm_tc16_dir, scm_dir_free);
scm_set_smob_print (scm_tc16_dir, scm_dir_print);
- scm_dot_string = scm_permanent_object (scm_from_locale_string ("."));
+ scm_dot_string = scm_from_locale_string (".");
#ifdef O_RDONLY
scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY));
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
-/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009 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
SCM_API scm_t_bits scm_tc16_dir;
-#define SCM_DIR_FLAG_OPEN (1L << 16)
+#define SCM_DIR_FLAG_OPEN (1L << 0)
#define SCM_DIRP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_dir))
-#define SCM_DIR_OPEN_P(x) (SCM_CELL_WORD_0 (x) & SCM_DIR_FLAG_OPEN)
+#define SCM_DIR_OPEN_P(x) (SCM_SMOB_FLAGS (x) & SCM_DIR_FLAG_OPEN)
\f
-/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009 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
#include <stdio.h>
#include <string.h>
+#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/print.h"
-#include "libguile/smob.h"
#include "libguile/dynwind.h"
#include "libguile/fluids.h"
#include "libguile/alist.h"
static size_t allocated_fluids_num = 0;
static char *allocated_fluids = NULL;
-static scm_t_bits tc16_fluid;
+#define IS_FLUID(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_fluid)
+#define FLUID_NUM(x) ((size_t)SCM_CELL_WORD_1(x))
-#define IS_FLUID(x) SCM_SMOB_PREDICATE(tc16_fluid, (x))
-#define FLUID_NUM(x) ((size_t)SCM_SMOB_DATA(x))
-#define FLUID_NEXT(x) SCM_SMOB_OBJECT_2(x)
-#define FLUID_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
-#define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
+#define IS_DYNAMIC_STATE(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_dynamic_state)
+#define DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x))
+#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y)))
-static scm_t_bits tc16_dynamic_state;
-#define IS_DYNAMIC_STATE(x) SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
-#define DYNAMIC_STATE_FLUIDS(x) SCM_SMOB_OBJECT(x)
-#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
-#define DYNAMIC_STATE_NEXT(x) SCM_SMOB_OBJECT_2(x)
-#define DYNAMIC_STATE_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
-#define SET_DYNAMIC_STATE_NEXT(x, y) SCM_SET_SMOB_OBJECT_2((x), (y))
-
-/* Weak lists of all dynamic states and all fluids.
- */
-static SCM all_dynamic_states = SCM_EOL;
-static SCM all_fluids = SCM_EOL;
-
-/* Make sure that all states have the right size. This must be called
- while fluid_admin_mutex is held.
-*/
+\f
+/* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_NUM fluids. */
static void
-resize_all_states ()
+grow_dynamic_state (SCM state)
{
- SCM new_vectors, state;
-
- /* Replacing the vector of a dynamic state must be done atomically:
- the old values must be copied into the new vector and the new
- vector must be installed without someone modifying the old vector
- concurrently. Since accessing a fluid should be lock-free, we
- need to put all threads to sleep when replacing a vector.
- However, when being single threaded, it is best not to do much.
- Therefore, we allocate the new vectors before going single
- threaded.
- */
-
- new_vectors = SCM_EOL;
- for (state = all_dynamic_states; !scm_is_null (state);
- state = DYNAMIC_STATE_NEXT (state))
- new_vectors = scm_cons (scm_c_make_vector (allocated_fluids_len,
- SCM_BOOL_F),
- new_vectors);
-
- scm_i_thread_put_to_sleep ();
- for (state = all_dynamic_states; !scm_is_null (state);
- state = DYNAMIC_STATE_NEXT (state))
- {
- SCM old_fluids = DYNAMIC_STATE_FLUIDS (state);
- SCM new_fluids = SCM_CAR (new_vectors);
- size_t i, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
-
- for (i = 0; i < old_len; i++)
- SCM_SIMPLE_VECTOR_SET (new_fluids, i,
- SCM_SIMPLE_VECTOR_REF (old_fluids, i));
- SET_DYNAMIC_STATE_FLUIDS (state, new_fluids);
- new_vectors = SCM_CDR (new_vectors);
- }
- scm_i_thread_wake_up ();
-}
+ SCM new_fluids;
+ SCM old_fluids = DYNAMIC_STATE_FLUIDS (state);
+ size_t i, new_len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
-/* This is called during GC, that is, while being single threaded.
- See next_fluid_num for a discussion why it is safe to access
- allocated_fluids here.
- */
-static void *
-scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED,
- void *dummy2 SCM_UNUSED,
- void *dummy3 SCM_UNUSED)
-{
- SCM *statep, *fluidp;
+ retry:
+ new_len = allocated_fluids_num;
+ new_fluids = scm_c_make_vector (new_len, SCM_BOOL_F);
- /* Scan all fluids and deallocate the unmarked ones.
- */
- fluidp = &all_fluids;
- while (!scm_is_null (*fluidp))
+ scm_i_pthread_mutex_lock (&fluid_admin_mutex);
+ if (new_len != allocated_fluids_num)
{
- if (!SCM_GC_MARK_P (*fluidp))
- {
- allocated_fluids_num -= 1;
- allocated_fluids[FLUID_NUM (*fluidp)] = 0;
- *fluidp = FLUID_NEXT (*fluidp);
- }
- else
- fluidp = FLUID_NEXT_LOC (*fluidp);
+ /* We lost the race. */
+ scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
+ goto retry;
}
- /* Scan all dynamic states and remove the unmarked ones. The live
- ones are updated for unallocated fluids.
- */
- statep = &all_dynamic_states;
- while (!scm_is_null (*statep))
- {
- if (!SCM_GC_MARK_P (*statep))
- *statep = DYNAMIC_STATE_NEXT (*statep);
- else
- {
- SCM fluids = DYNAMIC_STATE_FLUIDS (*statep);
- size_t len, i;
-
- len = SCM_SIMPLE_VECTOR_LENGTH (fluids);
- for (i = 0; i < len && i < allocated_fluids_len; i++)
- if (allocated_fluids[i] == 0)
- SCM_SIMPLE_VECTOR_SET (fluids, i, SCM_BOOL_F);
-
- statep = DYNAMIC_STATE_NEXT_LOC (*statep);
- }
- }
+ assert (allocated_fluids_num > old_len);
- return NULL;
-}
+ for (i = 0; i < old_len; i++)
+ SCM_SIMPLE_VECTOR_SET (new_fluids, i,
+ SCM_SIMPLE_VECTOR_REF (old_fluids, i));
+ SET_DYNAMIC_STATE_FLUIDS (state, new_fluids);
-static size_t
-fluid_free (SCM fluid)
-{
- /* The real work is done in scan_dynamic_states_and_fluids. We can
- not touch allocated_fluids etc here since a smob free routine can
- be run at any time, in any thread.
- */
- return 0;
+ scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
}
-static int
-fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+void
+scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
scm_puts ("#<fluid ", port);
scm_intprint ((int) FLUID_NUM (exp), 10, port);
scm_putc ('>', port);
- return 1;
+}
+
+void
+scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<dynamic-state ", port);
+ scm_intprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
}
static size_t
}
else
{
- /* During the following call, the GC might run and elements of
- allocated_fluids might bet set to zero. Also,
- allocated_fluids and allocated_fluids_len are used to scan
- all dynamic states during GC. Thus we need to make sure that
- no GC can run while updating these two variables.
- */
-
- char *prev_allocated_fluids;
+ /* Grow the vector of allocated fluids. */
+ /* FIXME: Since we use `scm_malloc ()', ALLOCATED_FLUIDS is scanned by
+ the GC; therefore, all fluids remain reachable for the entire
+ program lifetime. Hopefully this is not a problem in practice. */
char *new_allocated_fluids =
- scm_malloc (allocated_fluids_len + FLUID_GROW);
+ scm_gc_malloc (allocated_fluids_len + FLUID_GROW,
+ "allocated fluids");
/* Copy over old values and initialize rest. GC can not run
during these two operations since there is no safe point in
memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
n = allocated_fluids_len;
- prev_allocated_fluids = allocated_fluids;
+ /* Update the vector of allocated fluids. Dynamic states will
+ eventually be lazily grown to accomodate the new value of
+ ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
allocated_fluids = new_allocated_fluids;
allocated_fluids_len += FLUID_GROW;
-
- if (prev_allocated_fluids != NULL)
- free (prev_allocated_fluids);
-
- /* Now allocated_fluids and allocated_fluids_len are valid again
- and we can allow GCs to occur.
- */
- resize_all_states ();
}
allocated_fluids_num += 1;
"with its own dynamic state, you can use fluids for thread local storage.")
#define FUNC_NAME s_scm_make_fluid
{
- SCM fluid;
-
- SCM_NEWSMOB2 (fluid, tc16_fluid,
- (scm_t_bits) next_fluid_num (), SCM_UNPACK (SCM_EOL));
-
- /* The GC must not run until the fluid is properly entered into the
- list.
- */
- scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex);
- SET_FLUID_NEXT (fluid, all_fluids);
- all_fluids = fluid;
- scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
-
- return fluid;
+ return scm_cell (scm_tc7_fluid, (scm_t_bits) next_fluid_num ());
}
#undef FUNC_NAME
return IS_FLUID (obj);
}
-size_t
-scm_i_fluid_num (SCM fluid)
-{
- return FLUID_NUM (fluid);
-}
+
SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
(SCM fluid),
SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
SCM_VALIDATE_FLUID (1, fluid);
+
+ if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ {
+ /* We should only get there when the current thread's dynamic state
+ turns out to be too small compared to the set of currently allocated
+ fluids. */
+ assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
+
+ /* Lazily grow the current thread's dynamic state. */
+ grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
+
+ fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
+ }
+
return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
}
#undef FUNC_NAME
-SCM
-scm_i_fast_fluid_ref (size_t n)
-{
- SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
- return SCM_SIMPLE_VECTOR_REF (fluids, n);
-}
-
SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
(SCM fluid, SCM value),
"Set the value associated with @var{fluid} in the current dynamic root.")
SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
SCM_VALIDATE_FLUID (1, fluid);
+
+ if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ {
+ /* We should only get there when the current thread's dynamic state
+ turns out to be too small compared to the set of currently allocated
+ fluids. */
+ assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
+
+ /* Lazily grow the current thread's dynamic state. */
+ grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
+
+ fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
+ }
+
SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-void
-scm_i_fast_fluid_set_x (size_t n, SCM value)
-{
- SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
- SCM_SIMPLE_VECTOR_SET (fluids, n, value);
-}
-
static void
swap_fluids (SCM data)
{
scm_i_make_initial_dynamic_state ()
{
SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
- SCM state;
- SCM_NEWSMOB2 (state, tc16_dynamic_state,
- SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
- all_dynamic_states = state;
- return state;
+ return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids));
}
SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0,
"or of the current dynamic state when @var{parent} is omitted.")
#define FUNC_NAME s_scm_make_dynamic_state
{
- SCM fluids, state;
+ SCM fluids;
if (SCM_UNBNDP (parent))
parent = scm_current_dynamic_state ();
- scm_assert_smob_type (tc16_dynamic_state, parent);
+ SCM_ASSERT (IS_DYNAMIC_STATE (parent), parent, SCM_ARG1, FUNC_NAME);
fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent));
- SCM_NEWSMOB2 (state, tc16_dynamic_state,
- SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
-
- /* The GC must not run until the state is properly entered into the
- list.
- */
- scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex);
- SET_DYNAMIC_STATE_NEXT (state, all_dynamic_states);
- all_dynamic_states = state;
- scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
-
- return state;
+ return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids));
}
#undef FUNC_NAME
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
SCM old = t->dynamic_state;
- scm_assert_smob_type (tc16_dynamic_state, state);
+ SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, FUNC_NAME);
t->dynamic_state = state;
return old;
}
scm_dynwind_current_dynamic_state (SCM state)
{
SCM loc = scm_cons (state, SCM_EOL);
- scm_assert_smob_type (tc16_dynamic_state, state);
+ SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, NULL);
scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc,
SCM_F_WIND_EXPLICITLY);
scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc,
}
#undef FUNC_NAME
-void
-scm_fluids_prehistory ()
-{
- tc16_fluid = scm_make_smob_type ("fluid", 0);
- scm_set_smob_free (tc16_fluid, fluid_free);
- scm_set_smob_print (tc16_fluid, fluid_print);
-
- tc16_dynamic_state = scm_make_smob_type ("dynamic-state", 0);
- scm_set_smob_mark (tc16_dynamic_state, scm_markcdr);
-
- scm_c_hook_add (&scm_after_sweep_c_hook, scan_dynamic_states_and_fluids,
- 0, 0);
-}
void
scm_init_fluids ()
#ifndef SCM_FLUIDS_H
#define SCM_FLUIDS_H
-/* Copyright (C) 1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009 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
/* Fluids.
- Fluids are objects of a certain type (a smob) that can hold one SCM
- value per dynamic state. That is, modifications to this value are
- only visible to code that executes with the same dynamic state as
- the modifying code. When a new dynamic state is constructed, it
- inherits the values from its parent. Because each thread executes
- with its own dynamic state, you can use fluids for thread local
- storage.
-
- Each fluid is identified by a small integer. This integer is used
- to index a vector that holds the values of all fluids. A dynamic
- state consists of this vector, wrapped in a smob so that the vector
- can grow.
+ Fluids are objects of a certain type that can hold one SCM value per
+ dynamic state. That is, modifications to this value are only visible
+ to code that executes with the same dynamic state as the modifying
+ code. When a new dynamic state is constructed, it inherits the
+ values from its parent. Because each thread executes with its own
+ dynamic state, you can use fluids for thread local storage.
+
+ Each fluid is identified by a small integer. This integer is used to
+ index a vector that holds the values of all fluids. A dynamic state
+ consists of this vector, wrapped in an object so that the vector can
+ grow.
*/
/* The fastest way to acces/modify the value of a fluid. These macros
eventually.
*/
-#define SCM_FLUID_NUM(x) scm_i_fluid_num (x)
-#define SCM_FAST_FLUID_REF(n) scm_i_fast_fluid_ref (n)
-#define SCM_FAST_FLUID_SET_X(n, val) scm_i_fast_fluid_set_x ((n),(val))
-
SCM_API SCM scm_make_fluid (void);
SCM_API int scm_is_fluid (SCM obj);
SCM_API SCM scm_fluid_p (SCM fl);
SCM_API SCM scm_fluid_ref (SCM fluid);
SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
-SCM_API size_t scm_i_fluid_num (SCM fl);
-SCM_API SCM scm_i_fast_fluid_ref (size_t n);
-SCM_API void scm_i_fast_fluid_set_x (size_t n, SCM val);
SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
SCM (*cproc)(void *), void *cdata);
SCM_INTERNAL SCM scm_i_make_initial_dynamic_state (void);
-SCM_INTERNAL void scm_fluids_prehistory (void);
+SCM_INTERNAL void scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate);
+SCM_INTERNAL void scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_fluids (void);
#endif /* SCM_FLUIDS_H */
gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
might be possibilities if we've got other systems without ftruncate. */
-#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
+#if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
# define ftruncate(fd, size) chsize (fd, size)
-#undef HAVE_FTRUNCATE
-#define HAVE_FTRUNCATE 1
+# undef HAVE_FTRUNCATE
+# define HAVE_FTRUNCATE 1
#endif
#if SIZEOF_OFF_T == SIZEOF_INT
if (SCM_INPUT_PORT_P (port) && read_size > 0)
{
- pt->read_buf = scm_gc_malloc (read_size, "port buffer");
+ pt->read_buf = scm_gc_malloc_pointerless (read_size, "port buffer");
pt->read_pos = pt->read_end = pt->read_buf;
pt->read_buf_size = read_size;
}
if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
{
- pt->write_buf = scm_gc_malloc (write_size, "port buffer");
+ pt->write_buf = scm_gc_malloc_pointerless (write_size, "port buffer");
pt->write_pos = pt->write_buf;
pt->write_buf_size = write_size;
}
if (SCM_FPORTP (port))
{
- scm_t_fport *fp = SCM_FSTREAM (port);
+ scm_t_port *p;
+ scm_t_fport *fp;
+
+ /* XXX: In some cases, we can encounter a port with no associated ptab
+ entry. */
+ p = SCM_PTAB_ENTRY (port);
+ fp = (p != NULL) ? (scm_t_fport *) p->stream : NULL;
- if (fp->fdes == fd)
+ if ((fp != NULL) && (fp->fdes == fd))
{
fp->fdes = dup (fd);
if (fp->fdes == -1)
#define FUNC_NAME s_scm_open_file
{
SCM port;
- int fdes;
- int flags = 0;
- char *file;
- char *md;
- char *ptr;
+ int fdes, flags = 0;
+ unsigned int retries;
+ char *file, *md, *ptr;
scm_dynwind_begin (0);
}
ptr++;
}
- SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
- if (fdes == -1)
+
+ for (retries = 0, fdes = -1;
+ fdes < 0 && retries < 2;
+ retries++)
{
- int en = errno;
+ SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
+ if (fdes == -1)
+ {
+ int en = errno;
- SCM_SYSERROR_MSG ("~A: ~S",
- scm_cons (scm_strerror (scm_from_int (en)),
- scm_cons (filename, SCM_EOL)), en);
+ if (en == EMFILE && retries == 0)
+ /* Run the GC in case it collects open file ports that are no
+ longer referenced. */
+ scm_i_gc (FUNC_NAME);
+ else
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_cons (scm_strerror (scm_from_int (en)),
+ scm_cons (filename, SCM_EOL)), en);
+ }
}
+
port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), filename);
scm_dynwind_end ();
pt = SCM_PTAB_ENTRY(port);
{
scm_t_fport *fp
- = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port");
+ = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
+ "file port");
fp->fdes = fdes;
pt->rw_random = SCM_FDES_RANDOM_P (fdes);
#include "frames.h"
\f
-scm_t_bits scm_tc16_vm_frame;
+scm_t_bits scm_tc16_frame;
#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
SCM
-scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_t_uint8 *ip, scm_t_ptrdiff offset)
+scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
+ scm_t_uint8 *ip, scm_t_ptrdiff offset)
{
- struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
- "vmframe");
+ struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
+ "vmframe");
p->stack_holder = stack_holder;
p->fp = fp;
p->sp = sp;
p->ip = ip;
p->offset = offset;
- SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p);
+ SCM_RETURN_NEWSMOB (scm_tc16_frame, p);
}
static int
-vm_frame_print (SCM frame, SCM port, scm_print_state *pstate)
+frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<vm-frame ", port);
+ scm_puts ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
scm_putc (' ', port);
- scm_write (scm_vm_frame_program (frame), port);
+ scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
scm_puts (">", port);
return 1;
}
-static SCM
-vm_frame_mark (SCM obj)
-{
- return SCM_VM_FRAME_STACK_HOLDER (obj);
-}
-
-static size_t
-vm_frame_free (SCM obj)
-{
- struct scm_vm_frame *p = SCM_VM_FRAME_DATA (obj);
- scm_gc_free (p, sizeof(struct scm_vm_frame), "vmframe");
- return 0;
-}
-
+\f
/* Scheme interface */
-SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0,
+SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
(SCM obj),
"")
-#define FUNC_NAME s_scm_vm_frame_p
+#define FUNC_NAME s_scm_frame_p
{
- return SCM_BOOL (SCM_VM_FRAME_P (obj));
+ return scm_from_bool (SCM_VM_FRAME_P (obj));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
+SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_program
+#define FUNC_NAME s_scm_frame_procedure
{
SCM_VALIDATE_VM_FRAME (1, frame);
return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
+SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_arguments
+#define FUNC_NAME s_scm_frame_arguments
{
- SCM *fp;
- int i;
- struct scm_objcode *bp;
- SCM ret;
+ static SCM var = SCM_BOOL_F;
SCM_VALIDATE_VM_FRAME (1, frame);
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ if (scm_is_false (var))
+ var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
+ "frame-arguments");
- if (!bp->nargs)
- return SCM_EOL;
- else if (bp->nrest)
- ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
- else
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
-
- for (i = bp->nargs - 2; i >= 0; i--)
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
-
- return ret;
+ return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
+SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_source
+#define FUNC_NAME s_scm_frame_source
{
SCM *fp;
struct scm_objcode *bp;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
- (SCM frame, SCM index),
+/* The number of locals would be a simple thing to compute, if it weren't for
+ the presence of not-yet-active frames on the stack. So we have a cheap
+ heuristic to detect not-yet-active frames, and skip over them. Perhaps we
+ should represent them more usefully.
+*/
+SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
+ (SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_local_ref
+#define FUNC_NAME s_scm_frame_num_locals
{
- SCM *fp;
- unsigned int i;
- struct scm_objcode *bp;
-
+ SCM *sp, *p;
+ unsigned int n = 0;
+
SCM_VALIDATE_VM_FRAME (1, frame);
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ return scm_from_uint (n);
+}
+#undef FUNC_NAME
+
+/* Need same not-yet-active frame logic here as in frame-num-locals */
+SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
+ (SCM frame, SCM index),
+ "")
+#define FUNC_NAME s_scm_frame_local_ref
+{
+ SCM *sp, *p;
+ unsigned int n = 0;
+ unsigned int i;
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- return SCM_FRAME_VARIABLE (fp, i);
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ return *p;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
+/* Need same not-yet-active frame logic here as in frame-num-locals */
+SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
"")
-#define FUNC_NAME s_scm_vm_frame_local_set_x
+#define FUNC_NAME s_scm_frame_local_set_x
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- SCM_FRAME_VARIABLE (fp, i) = val;
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ {
+ *p = val;
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
+}
+#undef FUNC_NAME
- return SCM_UNSPECIFIED;
+SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_instruction_pointer
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_VM_FRAME_IP (frame)
+ - SCM_PROGRAM_DATA (scm_frame_procedure (frame))->base));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0,
+SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_return_address
+#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0,
+SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_mv_return_address
+#define FUNC_NAME s_scm_frame_mv_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
+SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_dynamic_link
+#define FUNC_NAME s_scm_frame_dynamic_link
{
SCM_VALIDATE_VM_FRAME (1, frame);
/* fixme: munge fp if holder is a continuation */
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_stack
-{
- SCM *top, *bottom, ret = SCM_EOL;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- top = SCM_VM_FRAME_SP (frame);
- bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
- while (bottom <= top)
- ret = scm_cons (*bottom++, ret);
-
- return ret;
-}
-#undef FUNC_NAME
-
extern SCM
-scm_c_vm_frame_prev (SCM frame)
+scm_c_frame_prev (SCM frame)
{
SCM *this_fp, *new_fp, *new_sp;
this_fp = SCM_VM_FRAME_FP (frame);
if (new_fp)
{ new_fp = RELOC (frame, new_fp);
new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
- return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
- new_fp, new_sp,
- SCM_FRAME_RETURN_ADDRESS (this_fp),
- SCM_VM_FRAME_OFFSET (frame));
+ return scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
+ new_fp, new_sp,
+ SCM_FRAME_RETURN_ADDRESS (this_fp),
+ SCM_VM_FRAME_OFFSET (frame));
}
else
return SCM_BOOL_F;
void
scm_bootstrap_frames (void)
{
- scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
- scm_set_smob_mark (scm_tc16_vm_frame, vm_frame_mark);
- scm_set_smob_free (scm_tc16_vm_frame, vm_frame_free);
- scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print);
+ scm_tc16_frame = scm_make_smob_type ("frame", 0);
+ scm_set_smob_print (scm_tc16_frame, frame_print);
scm_c_register_extension ("libguile", "scm_init_frames",
(scm_t_extension_init_func)scm_init_frames, NULL);
}
* VM frames
*/
+/*
+ * It's a little confusing, but there are two representations of frames in this
+ * file: frame pointers and Scheme objects wrapping those frame pointers. The
+ * former uses the SCM_FRAME_... macro prefix, the latter SCM_VM_FRAME_..
+ * prefix.
+ *
+ * The confusing thing is that only Scheme frame objects have functions that use
+ * them, and they use the scm_frame_.. prefix. Hysterical raisins.
+ */
+
/* VM Frame Layout
---------------
| ... |
- | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp)
- +==================+
+ | Intermed. val. 0 | <- fp + nargs + nlocs
+ +------------------+
| Local variable 1 |
- | Local variable 0 | <- fp + bp->nargs
+ | Local variable 0 | <- fp + nargs
| Argument 1 |
- | Argument 0 | <- fp
+ | Argument 0 | <- fp = SCM_FRAME_STACK_ADDRESS (fp)
| Program | <- fp - 1
- +------------------+
- | Return address |
+ +==================+
+ | Return address | <- SCM_FRAME_UPPER_ADDRESS (fp)
| MV return address|
| Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
+==================+
assumed to be as long as SCM objects. */
#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4)
-#define SCM_FRAME_UPPER_ADDRESS(fp) \
- (fp \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_STACK_ADDRESS(fp) (fp)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (fp - 2)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 4)
#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) SCM_UNPACK (x))
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
-#define SCM_FRAME_VARIABLE(fp,i) fp[i]
-#define SCM_FRAME_PROGRAM(fp) fp[-1]
+#define SCM_FRAME_VARIABLE(fp,i) SCM_FRAME_STACK_ADDRESS (fp)[i]
+#define SCM_FRAME_PROGRAM(fp) SCM_FRAME_STACK_ADDRESS (fp)[-1]
\f
/*
* Heap frames
*/
-SCM_API scm_t_bits scm_tc16_vm_frame;
+SCM_API scm_t_bits scm_tc16_frame;
-struct scm_vm_frame
+struct scm_frame
{
SCM stack_holder;
SCM *fp;
scm_t_ptrdiff offset;
};
-#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_frame, x)
-#define SCM_VM_FRAME_DATA(x) ((struct scm_vm_frame*)SCM_SMOB_DATA (x))
+#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_frame, x)
+#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_SMOB_DATA (x))
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
-SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_t_uint8 *ip, scm_t_ptrdiff offset);
-SCM_API SCM scm_vm_frame_p (SCM obj);
-SCM_API SCM scm_vm_frame_program (SCM frame);
-SCM_API SCM scm_vm_frame_arguments (SCM frame);
-SCM_API SCM scm_vm_frame_source (SCM frame);
-SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index);
-SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
-SCM_API SCM scm_vm_frame_return_address (SCM frame);
-SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
-SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
-SCM_API SCM scm_vm_frame_stack (SCM frame);
-
-SCM_API SCM scm_c_vm_frame_prev (SCM frame);
+SCM_API SCM scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
+ scm_t_uint8 *ip, scm_t_ptrdiff offset);
+SCM_API SCM scm_frame_p (SCM obj);
+SCM_API SCM scm_frame_procedure (SCM frame);
+SCM_API SCM scm_frame_arguments (SCM frame);
+SCM_API SCM scm_frame_source (SCM frame);
+SCM_API SCM scm_frame_num_locals (SCM frame);
+SCM_API SCM scm_frame_local_ref (SCM frame, SCM index);
+SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_frame_instruction_pointer (SCM frame);
+SCM_API SCM scm_frame_return_address (SCM frame);
+SCM_API SCM scm_frame_mv_return_address (SCM frame);
+SCM_API SCM scm_frame_dynamic_link (SCM frame);
+
+SCM_API SCM scm_c_frame_prev (SCM frame);
SCM_INTERNAL void scm_bootstrap_frames (void);
SCM_INTERNAL void scm_init_frames (void);
+++ /dev/null
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public 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
- */
-
-
-\f
-
-#if 0
-
-/* This whole file is not being compiled. See futures.h for the
- reason.
-*/
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/_scm.h"
-#include "libguile/eval.h"
-#include "libguile/ports.h"
-#include "libguile/validate.h"
-#include "libguile/stime.h"
-#include "libguile/threads.h"
-
-#include "libguile/futures.h"
-
-#define LINK(list, obj) \
-do { \
- SCM_SET_FUTURE_NEXT (obj, list); \
- list = obj; \
-} while (0)
-
-#define UNLINK(list, obj) \
-do { \
- obj = list; \
- list = SCM_FUTURE_NEXT (list); \
-} while (0)
-
-scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
-static SCM futures = SCM_EOL;
-static SCM young = SCM_EOL;
-static SCM old = SCM_EOL;
-static SCM undead = SCM_EOL;
-
-static long last_switch;
-
-#ifdef SCM_FUTURES_DEBUG
-static int n_dead = 0;
-
-static SCM
-count (SCM ls)
-{
- int n = 0;
- while (!scm_is_null (ls))
- {
- ++n;
- ls = SCM_FUTURE_NEXT (ls);
- }
- return scm_from_int (n);
-}
-
-extern SCM scm_future_cache_status (void);
-
-SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0,
- (),
- "Return a list containing number of futures, youngs, olds, undeads and deads.")
-#define FUNC_NAME s_scm_future_cache_status
-{
- int nd = n_dead;
- n_dead = 0;
- return scm_list_5 (count (futures),
- count (young),
- count (old),
- count (undead),
- scm_from_int (nd));
-}
-#undef FUNC_NAME
-
-#endif
-
-SCM *scm_loc_sys_thread_handler;
-
-SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0,
- (SCM thunk),
- "Make a future evaluating THUNK.")
-#define FUNC_NAME s_scm_make_future
-{
- SCM_VALIDATE_THUNK (1, thunk);
- return scm_i_make_future (thunk);
-}
-#undef FUNC_NAME
-
-static char *s_future = "future";
-
-static void
-cleanup (scm_t_future *future)
-{
- scm_i_pthread_mutex_destroy (&future->mutex);
- scm_i_pthread_cond_destroy (&future->cond);
- scm_gc_free (future, sizeof (*future), s_future);
-#ifdef SCM_FUTURES_DEBUG
- ++n_dead;
-#endif
-}
-
-static SCM
-future_loop (scm_t_future *future)
-{
- scm_i_scm_pthread_mutex_lock (&future->mutex);
- do {
- if (future->status == SCM_FUTURE_SIGNAL_ME)
- scm_i_pthread_cond_broadcast (&future->cond);
- future->status = SCM_FUTURE_COMPUTING;
- future->data = (SCM_CLOSUREP (future->data)
- ? scm_i_call_closure_0 (future->data)
- : scm_call_0 (future->data));
- scm_i_scm_pthread_cond_wait (&future->cond, &future->mutex);
- } while (!future->die_p);
- future->status = SCM_FUTURE_DEAD;
- scm_i_pthread_mutex_unlock (&future->mutex);
- return SCM_UNSPECIFIED;
-}
-
-static SCM
-future_handler (scm_t_future *future, SCM key, SCM args)
-{
- future->status = SCM_FUTURE_DEAD;
- scm_i_pthread_mutex_unlock (&future->mutex);
- return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
-}
-
-static SCM
-alloc_future (SCM thunk)
-{
- scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future);
- SCM future;
- f->data = SCM_BOOL_F;
- scm_i_pthread_mutex_init (&f->mutex, NULL);
- scm_i_pthread_cond_init (&f->cond, NULL);
- f->die_p = 0;
- f->status = SCM_FUTURE_TASK_ASSIGNED;
- scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
- SCM_NEWSMOB2 (future, scm_tc16_future, futures, f);
- SCM_SET_FUTURE_DATA (future, thunk);
- futures = future;
- scm_i_pthread_mutex_unlock (&future_admin_mutex);
- scm_spawn_thread ((scm_t_catch_body) future_loop,
- SCM_FUTURE (future),
- (scm_t_catch_handler) future_handler,
- SCM_FUTURE (future));
- return future;
-}
-
-static void
-kill_future (SCM future)
-{
- SCM_FUTURE (future)->die_p = 1;
- LINK (undead, future);
-}
-
-SCM
-scm_i_make_future (SCM thunk)
-{
- SCM future;
- scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
- while (1)
- {
- if (!scm_is_null (old))
- UNLINK (old, future);
- else if (!scm_is_null (young))
- UNLINK (young, future);
- else
- {
- scm_i_pthread_mutex_unlock (&future_admin_mutex);
- return alloc_future (thunk);
- }
- if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
- kill_future (future);
- else if (!SCM_FUTURE_ALIVE_P (future))
- {
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- cleanup (SCM_FUTURE (future));
- }
- else
- break;
- }
- LINK (futures, future);
- scm_i_pthread_mutex_unlock (&future_admin_mutex);
- SCM_SET_FUTURE_DATA (future, thunk);
- SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED);
- scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- return future;
-}
-
-static SCM
-future_mark (SCM ptr) {
- return SCM_FUTURE_DATA (ptr);
-}
-
-static int
-future_print (SCM exp, SCM port, scm_print_state *pstate)
-{
- int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<future ", port);
- SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (SCM_FUTURE_DATA (exp), port, pstate);
- SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
- return !0;
-}
-
-SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
- (SCM future),
- "If the future @var{x} has not been computed yet, compute and\n"
- "return @var{x}, otherwise just return the previously computed\n"
- "value.")
-#define FUNC_NAME s_scm_future_ref
-{
- SCM res;
- SCM_VALIDATE_FUTURE (1, future);
- scm_i_scm_pthread_mutex_lock (SCM_FUTURE_MUTEX (future));
- if (SCM_FUTURE_STATUS (future) != SCM_FUTURE_COMPUTING)
- {
- SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_SIGNAL_ME);
- scm_i_scm_pthread_cond_wait (SCM_FUTURE_COND (future),
- SCM_FUTURE_MUTEX (future));
- }
- if (!SCM_FUTURE_ALIVE_P (future))
- {
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- SCM_MISC_ERROR ("requesting result from failed future ~A",
- scm_list_1 (future));
- }
- res = SCM_FUTURE_DATA (future);
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- return res;
-}
-#undef FUNC_NAME
-
-static void
-kill_futures (SCM victims)
-{
- while (!scm_is_null (victims))
- {
- SCM future;
- UNLINK (victims, future);
- kill_future (future);
- scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
- }
-}
-
-static void
-cleanup_undead ()
-{
- SCM next = undead, *nextloc = &undead;
- while (!scm_is_null (next))
- {
- if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next)))
- goto next;
- else if (SCM_FUTURE_ALIVE_P (next))
- {
- scm_i_pthread_cond_signal (SCM_FUTURE_COND (next));
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
- next:
- SCM_SET_GC_MARK (next);
- nextloc = SCM_FUTURE_NEXTLOC (next);
- next = *nextloc;
- }
- else
- {
- SCM future;
- UNLINK (next, future);
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- cleanup (SCM_FUTURE (future));
- *nextloc = next;
- }
- }
-}
-
-static void
-mark_futures (SCM futures)
-{
- while (!scm_is_null (futures))
- {
- SCM_SET_GC_MARK (futures);
- futures = SCM_FUTURE_NEXT (futures);
- }
-}
-
-static void *
-scan_futures (void *dummy1, void *dummy2, void *dummy3)
-{
- SCM next, *nextloc;
-
- long now = scm_c_get_internal_run_time ();
- if (now - last_switch > SCM_TIME_UNITS_PER_SECOND)
- {
- /* switch out old (> 1 sec), unused futures */
- kill_futures (old);
- old = young;
- young = SCM_EOL;
- last_switch = now;
- }
- else
- mark_futures (young);
-
- next = futures;
- nextloc = &futures;
- while (!scm_is_null (next))
- {
- if (!SCM_GC_MARK_P (next))
- goto free;
- keep:
- nextloc = SCM_FUTURE_NEXTLOC (next);
- next = *nextloc;
- }
- goto exit;
- while (!scm_is_null (next))
- {
- if (SCM_GC_MARK_P (next))
- {
- *nextloc = next;
- goto keep;
- }
- free:
- {
- SCM future;
- UNLINK (next, future);
- SCM_SET_GC_MARK (future);
- LINK (young, future);
- }
- }
- *nextloc = SCM_EOL;
- exit:
- cleanup_undead ();
- mark_futures (old);
- return 0;
-}
-
-scm_t_bits scm_tc16_future;
-
-void
-scm_init_futures ()
-{
- last_switch = scm_c_get_internal_run_time ();
-
- scm_loc_sys_thread_handler
- = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F));
-
- scm_tc16_future = scm_make_smob_type ("future", 0);
- scm_set_smob_mark (scm_tc16_future, future_mark);
- scm_set_smob_print (scm_tc16_future, future_print);
-
- scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0);
-#include "libguile/futures.x"
-}
-
-#endif
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* classes: h_files */
-
-#ifndef SCM_FUTURES_H
-#define SCM_FUTURES_H
-
-/* Copyright (C) 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public 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
- */
-
-\f
-
-#if 0
-
-/* Futures have the following known bugs, which should be fixed before
- including them in Guile:
-
- - The implementation of the thread cache needs to be better so that
- it behaves reasonable under heavy use.
-
- - The dynamic state of a thread needs to be properly initialized
- when it is retrieved from the cache.
-*/
-
-#include "libguile/__scm.h"
-#include "libguile/threads.h"
-
-\f
-
-typedef struct scm_t_future {
- SCM data;
- scm_i_pthread_mutex_t mutex;
- scm_i_pthread_cond_t cond;
- int status;
- int die_p;
-} scm_t_future;
-
-#define SCM_FUTURE_DEAD 0
-#define SCM_FUTURE_SIGNAL_ME -1
-#define SCM_FUTURE_COMPUTING 1
-#define SCM_FUTURE_TASK_ASSIGNED 2
-
-#define SCM_VALIDATE_FUTURE(pos, obj) \
- SCM_ASSERT_TYPE (SCM_TYP16_PREDICATE (scm_tc16_future, obj), \
- obj, pos, FUNC_NAME, "future");
-#define SCM_FUTURE(future) ((scm_t_future *) SCM_SMOB_DATA_2 (future))
-#define SCM_FUTURE_MUTEX(future) (&SCM_FUTURE (future)->mutex)
-#define SCM_FUTURE_COND(future) (&SCM_FUTURE (future)->cond)
-#define SCM_FUTURE_STATUS(future) (SCM_FUTURE (future)->status)
-#define SCM_SET_FUTURE_STATUS(future, x) \
- do { SCM_FUTURE (future)->status = (x); } while (0)
-#define SCM_FUTURE_ALIVE_P(future) (SCM_FUTURE_STATUS (future))
-#define SCM_FUTURE_DATA(future) (SCM_FUTURE (future)->data)
-#define SCM_SET_FUTURE_DATA(future, x) \
- do { SCM_FUTURE (future)->data = (x); } while (0)
-#define SCM_FUTURE_NEXT SCM_SMOB_OBJECT
-#define SCM_FUTURE_NEXTLOC SCM_SMOB_OBJECT_LOC
-#define SCM_SET_FUTURE_NEXT SCM_SET_SMOB_OBJECT
-
-SCM_API scm_t_bits scm_tc16_future;
-
-extern SCM *scm_loc_sys_thread_handler;
-
-SCM_INTERNAL SCM scm_i_make_future (SCM thunk);
-SCM_API SCM scm_make_future (SCM thunk);
-SCM_API SCM scm_future_ref (SCM future);
-
-void scm_init_futures (void);
-
-#endif /* Futures are disabled for now. */
-
-#endif /* SCM_FUTURES_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 <assert.h>
-#include <stdio.h>
-#include <count-one-bits.h>
-
-#include <gmp.h>
-
-#include "libguile/_scm.h"
-#include "libguile/async.h"
-#include "libguile/deprecation.h"
-#include "libguile/eval.h"
-#include "libguile/gc.h"
-#include "libguile/hashtab.h"
-#include "libguile/numbers.h"
-#include "libguile/ports.h"
-#include "libguile/private-gc.h"
-#include "libguile/root.h"
-#include "libguile/smob.h"
-#include "libguile/srfi-4.h"
-#include "libguile/stackchk.h"
-#include "libguile/stime.h"
-#include "libguile/strings.h"
-#include "libguile/struct.h"
-#include "libguile/tags.h"
-#include "libguile/arrays.h"
-#include "libguile/validate.h"
-#include "libguile/vectors.h"
-#include "libguile/weaks.h"
-
-#include "libguile/private-gc.h"
-
-long int scm_i_deprecated_memory_return;
-
-
-/* During collection, this accumulates structures which are to be freed.
- */
-SCM scm_i_structs_to_free;
-
-/*
- Init all the free cells in CARD, prepending to *FREE_LIST.
-
- Return: FREE_COUNT, the number of cells collected. This is
- typically the length of the *FREE_LIST, but for some special cases,
- we do not actually free the cell. To make the numbers match up, we
- do increase the FREE_COUNT.
-
- It would be cleaner to have a separate function sweep_value (), but
- that is too slow (functions with switch statements can't be
- inlined).
-
- NOTE:
-
- For many types of cells, allocation and a de-allocation involves
- calling malloc () and free (). This is costly for small objects (due
- to malloc/free overhead.) (should measure this).
-
- It might also be bad for threads: if several threads are allocating
- strings concurrently, then mallocs for both threads may have to
- fiddle with locks.
-
- It might be interesting to add a separate memory pool for small
- objects to each freelist.
-
- --hwn.
- */
-int
-scm_i_sweep_card (scm_t_cell *card, SCM *free_list, scm_t_heap_segment *seg)
-#define FUNC_NAME "sweep_card"
-{
- scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (card);
- scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
- scm_t_cell *p = card;
- int span = seg->span;
- int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
- int free_count = 0;
-
- /*
- I tried something fancy with shifting by one bit every word from
- the bitvec in turn, but it wasn't any faster, but quite a bit
- hairier.
- */
- for (p += offset; p < end; p += span, offset += span)
- {
- SCM scmptr = PTR2SCM (p);
- if (SCM_C_BVEC_GET (bitvec, offset))
- continue;
- free_count++;
- switch (SCM_TYP7 (scmptr))
- {
- case scm_tcs_struct:
- /* The card can be swept more than once. Check that it's
- * the first time!
- */
- if (!SCM_STRUCT_GC_CHAIN (scmptr))
- {
- /* Structs need to be freed in a special order.
- * This is handled by GC C hooks in struct.c.
- */
- SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
- scm_i_structs_to_free = scmptr;
- }
- continue;
-
- case scm_tcs_cons_imcar:
- case scm_tcs_cons_nimcar:
- case scm_tcs_closures:
- case scm_tc7_pws:
- break;
- case scm_tc7_wvect:
- case scm_tc7_vector:
- scm_i_vector_free (scmptr);
- break;
-
- case scm_tc7_number:
- switch SCM_TYP16 (scmptr)
- {
- case scm_tc16_real:
- break;
- case scm_tc16_big:
- mpz_clear (SCM_I_BIG_MPZ (scmptr));
- /* nothing else to do here since the mpz is in a double cell */
- break;
- case scm_tc16_complex:
- scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
- "complex");
- break;
- case scm_tc16_fraction:
- /* nothing to do here since the num/denum of a fraction
- are proper SCM objects themselves. */
- break;
- }
- break;
- case scm_tc7_string:
- scm_i_string_free (scmptr);
- break;
- case scm_tc7_stringbuf:
- scm_i_stringbuf_free (scmptr);
- break;
- case scm_tc7_symbol:
- scm_i_symbol_free (scmptr);
- break;
- case scm_tc7_variable:
- break;
- case scm_tc7_program:
- break;
- case scm_tcs_subrs:
- /* the various "subrs" (primitives) are never freed */
- continue;
- case scm_tc7_port:
- if SCM_OPENP (scmptr)
- {
- int k = SCM_PTOBNUM (scmptr);
- size_t mm;
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (!(k < scm_numptob))
- {
- fprintf (stderr, "undefined port type");
- abort ();
- }
-#endif
- /* Keep "revealed" ports alive. */
- if (scm_revealed_count (scmptr) > 0)
- continue;
-
- /* Yes, I really do mean scm_ptobs[k].free */
- /* rather than ftobs[k].close. .close */
- /* is for explicit CLOSE-PORT by user */
- mm = scm_ptobs[k].free (scmptr);
-
- if (mm != 0)
- {
-#if SCM_ENABLE_DEPRECATED == 1
- scm_c_issue_deprecation_warning
- ("Returning non-0 from a port free function is "
- "deprecated. Use scm_gc_free et al instead.");
- scm_c_issue_deprecation_warning_fmt
- ("(You just returned non-0 while freeing a %s.)",
- SCM_PTOBNAME (k));
- scm_i_deprecated_memory_return += mm;
-#else
- abort ();
-#endif
- }
-
- SCM_SETSTREAM (scmptr, 0);
- scm_i_remove_port (scmptr);
- SCM_CLR_PORT_OPEN_FLAG (scmptr);
- }
- break;
- case scm_tc7_smob:
- switch SCM_TYP16 (scmptr)
- {
- case scm_tc_free_cell:
- break;
- default:
- {
- int k;
- k = SCM_SMOBNUM (scmptr);
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (!(k < scm_numsmob))
- {
- fprintf (stderr, "undefined smob type");
- abort ();
- }
-#endif
- if (scm_smobs[k].free)
- {
- size_t mm;
- mm = scm_smobs[k].free (scmptr);
- if (mm != 0)
- {
-#if SCM_ENABLE_DEPRECATED == 1
- scm_c_issue_deprecation_warning
- ("Returning non-0 from a smob free function is "
- "deprecated. Use scm_gc_free et al instead.");
- scm_c_issue_deprecation_warning_fmt
- ("(You just returned non-0 while freeing a %s.)",
- SCM_SMOBNAME (k));
- scm_i_deprecated_memory_return += mm;
-#else
- abort ();
-#endif
- }
- }
- break;
- }
- }
- break;
- default:
- fprintf (stderr, "unknown type");
- abort ();
- }
-
- SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
- SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
- *free_list = scmptr;
- }
-
- return free_count;
-}
-#undef FUNC_NAME
-
-
-/*
- Like sweep, but no complicated logic to do the sweeping.
- */
-int
-scm_i_init_card_freelist (scm_t_cell *card, SCM *free_list,
- scm_t_heap_segment *seg)
-{
- int span = seg->span;
- scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
- scm_t_cell *p = end - span;
- int collected = 0;
- scm_t_c_bvec_long *bvec_ptr = (scm_t_c_bvec_long*) seg->bounds[1];
- int idx = (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
-
- bvec_ptr += idx * SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
- SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
-
- /*
- ASSUMPTION: n_header_cells <= 2.
- */
- for (; p > card; p -= span)
- {
- const SCM scmptr = PTR2SCM (p);
- SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
- SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
- *free_list = scmptr;
- collected ++;
- }
-
- return collected;
-}
-
-/*
- Amount of cells marked in this cell, measured in 1-cells.
- */
-int
-scm_i_card_marked_count (scm_t_cell *card, int span)
-{
- scm_t_c_bvec_long* bvec = SCM_GC_CARD_BVEC (card);
- scm_t_c_bvec_long* bvec_end = (bvec + SCM_GC_CARD_BVEC_SIZE_IN_LONGS);
-
- int count = 0;
- while (bvec < bvec_end)
- {
- count += count_one_bits_l (*bvec);
- bvec ++;
- }
- return count * span;
-}
-
-void
-scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
-{
- scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (p);
- scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
- int span = seg->span;
- int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
-
- if (!bitvec)
- /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
- return;
-
- for (p += offset; p < end; p += span, offset += span)
- {
- scm_t_bits tag = -1;
- SCM scmptr = PTR2SCM (p);
-
- if (!SCM_C_BVEC_GET (bitvec, offset))
- continue;
-
- tag = SCM_TYP7 (scmptr);
- if (tag == scm_tc7_smob || tag == scm_tc7_number)
- {
- /* Record smobs and numbers under 16 bits of the tag, so the
- different smob objects are distinguished, and likewise the
- different numbers big, real, complex and fraction. */
- tag = SCM_TYP16(scmptr);
- }
- else
- switch (tag)
- {
- case scm_tcs_cons_imcar:
- tag = scm_tc2_int;
- break;
- case scm_tcs_cons_nimcar:
- tag = scm_tc3_cons;
- break;
-
- case scm_tcs_struct:
- tag = scm_tc3_struct;
- break;
- case scm_tcs_closures:
- tag = scm_tc3_closure;
- break;
- case scm_tcs_subrs:
- tag = scm_tc7_asubr;
- break;
- }
-
- {
- SCM handle = scm_hashq_create_handle_x (hashtab,
- scm_from_int (tag), SCM_INUM0);
- SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
- }
- }
-}
-
-/* TAG is the tag word of a cell, return a string which is its name, or NULL
- if unknown. Currently this is only used by gc-live-object-stats and the
- distinctions between types are oriented towards what that code records
- while scanning what's alive. */
-char const *
-scm_i_tag_name (scm_t_bits tag)
-{
- switch (tag & 0x7F) /* 7 bits */
- {
- case scm_tcs_struct:
- return "struct";
- case scm_tcs_cons_imcar:
- return "cons (immediate car)";
- case scm_tcs_cons_nimcar:
- return "cons (non-immediate car)";
- case scm_tcs_closures:
- return "closures";
- case scm_tc7_pws:
- return "pws";
- case scm_tc7_program:
- return "program";
- case scm_tc7_wvect:
- return "weak vector";
- case scm_tc7_vector:
- return "vector";
- case scm_tc7_number:
- switch (tag)
- {
- case scm_tc16_real:
- return "real";
- case scm_tc16_big:
- return "bignum";
- case scm_tc16_complex:
- return "complex number";
- case scm_tc16_fraction:
- return "fraction";
- }
- /* shouldn't reach here unless there's a new class of numbers */
- return "number";
- case scm_tc7_string:
- return "string";
- case scm_tc7_stringbuf:
- return "string buffer";
- case scm_tc7_symbol:
- return "symbol";
- case scm_tc7_variable:
- return "variable";
- case scm_tcs_subrs:
- return "subrs";
- case scm_tc7_port:
- return "port";
- case scm_tc7_smob:
- /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
- entry should be ok for our return here */
- return scm_smobs[SCM_TC2SMOBNUM (tag)].name;
- }
-
- return NULL;
-}
-
-
-#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
-
-typedef struct scm_dbg_t_list_cell {
- scm_t_bits car;
- struct scm_dbg_t_list_cell * cdr;
-} scm_dbg_t_list_cell;
-
-
-typedef struct scm_dbg_t_double_cell {
- scm_t_bits word_0;
- scm_t_bits word_1;
- scm_t_bits word_2;
- scm_t_bits word_3;
-} scm_dbg_t_double_cell;
-
-
-int scm_dbg_gc_marked_p (SCM obj);
-scm_t_cell * scm_dbg_gc_get_card (SCM obj);
-scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);
-
-
-int
-scm_dbg_gc_marked_p (SCM obj)
-{
- if (!SCM_IMP (obj))
- return SCM_GC_MARK_P (obj);
- else
- return 0;
-}
-
-scm_t_cell *
-scm_dbg_gc_get_card (SCM obj)
-{
- if (!SCM_IMP (obj))
- return SCM_GC_CELL_CARD (obj);
- else
- return NULL;
-}
-
-scm_t_c_bvec_long *
-scm_dbg_gc_get_bvec (SCM obj)
-{
- if (!SCM_IMP (obj))
- return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
- else
- return NULL;
-}
-
-#endif
+++ /dev/null
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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 <assert.h>
-#include <stdio.h>
-
-#include "libguile/private-gc.h"
-#include "libguile/gc.h"
-#include "libguile/deprecation.h"
-#include "libguile/private-gc.h"
-
-scm_t_cell_type_statistics scm_i_master_freelist;
-scm_t_cell_type_statistics scm_i_master_freelist2;
-
-/*
-
-In older versions of GUILE GC there was extensive support for
-debugging freelists. This was useful, since the freelist was kept
-inside the heap, and writing to an object that was GC'd would mangle
-the list. Mark bits are now separate, and checking for sane cell
-access can be done much more easily by simply checking if the mark bit
-is unset before allocation. --hwn
-
-*/
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-#if defined(GUILE_DEBUG_FREELIST)
-
-SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
- (),
- "DEPRECATED\n")
-#define FUNC_NAME "s_scm_map_free_list"
-{
- scm_c_issue_deprecation_warning ("map-free-list has been removed from GUILE. Doing nothing\n");
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
- (SCM flag),
- "DEPRECATED.\n")
-#define FUNC_NAME "s_scm_gc_set_debug_check_freelist_x"
-{
- scm_c_issue_deprecation_warning ("gc-set-debug-check-freelist! has been removed from GUILE. Doing nothing\n");
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-#endif /* defined (GUILE_DEBUG) */
-#endif /* deprecated */
-
-static void
-scm_init_freelist (scm_t_cell_type_statistics *freelist,
- int span,
- int min_yield_percentage)
-{
- if (min_yield_percentage < 1)
- min_yield_percentage = 1;
- if (min_yield_percentage > 99)
- min_yield_percentage = 99;
-
- freelist->heap_segment_idx = -1;
- freelist->min_yield_fraction = min_yield_percentage / 100.0;
- freelist->span = span;
- freelist->swept = 0;
- freelist->collected = 0;
- freelist->heap_total_cells = 0;
-}
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-size_t scm_default_init_heap_size_1;
-int scm_default_min_yield_1;
-size_t scm_default_init_heap_size_2;
-int scm_default_min_yield_2;
-size_t scm_default_max_segment_size;
-
-static void
-check_deprecated_heap_vars (void) {
- if (scm_default_init_heap_size_1 ||
- scm_default_min_yield_1||
- scm_default_init_heap_size_2||
- scm_default_min_yield_2||
- scm_default_max_segment_size)
- {
- scm_c_issue_deprecation_warning ("Tuning heap parameters with C variables is deprecated. Use environment variables instead.");
- }
-}
-#else
-static void check_deprecated_heap_vars (void) { }
-#endif
-
-void
-scm_gc_init_freelist (void)
-{
- const char *error_message =
- "Could not allocate initial heap of %uld.\n"
- "Try adjusting GUILE_INIT_SEGMENT_SIZE_%d\n";
-
- int init_heap_size_1
- = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", SCM_DEFAULT_INIT_HEAP_SIZE_1);
- int init_heap_size_2
- = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2);
-
- scm_init_freelist (&scm_i_master_freelist2, 2,
- scm_getenv_int ("GUILE_MIN_YIELD_2", SCM_DEFAULT_MIN_YIELD_2));
- scm_init_freelist (&scm_i_master_freelist, 1,
- scm_getenv_int ("GUILE_MIN_YIELD_1", SCM_DEFAULT_MIN_YIELD_1));
-
- scm_max_segment_size = scm_getenv_int ("GUILE_MAX_SEGMENT_SIZE", SCM_DEFAULT_MAX_SEGMENT_SIZE);
-
- if (scm_max_segment_size <= 0)
- scm_max_segment_size = SCM_DEFAULT_MAX_SEGMENT_SIZE;
-
- if (scm_i_get_new_heap_segment (&scm_i_master_freelist,
- init_heap_size_1, return_on_error) == -1) {
- fprintf (stderr, error_message, init_heap_size_1, 1);
- abort ();
- }
- if (scm_i_get_new_heap_segment (&scm_i_master_freelist2,
- init_heap_size_2, return_on_error) == -1) {
- fprintf (stderr, error_message, init_heap_size_2, 2);
- abort ();
- }
-
- check_deprecated_heap_vars ();
-}
-
-
-
-void
-scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist)
-{
- freelist->collected = 0;
- freelist->swept = 0;
- /*
- at the end we simply start with the lowest segment again.
- */
- freelist->heap_segment_idx = -1;
-}
-
-
-/*
- Returns how many more cells we should allocate according to our
- policy. May return negative if we don't need to allocate more.
-
-
- The new yield should at least equal gc fraction of new heap size, i.e.
-
- c + dh > f * (h + dh)
-
- c : collected
- f : min yield fraction
- h : heap size
- dh : size of new heap segment
-
- this gives dh > (f * h - c) / (1 - f).
-*/
-float
-scm_i_gc_heap_size_delta (scm_t_cell_type_statistics * freelist)
-{
- float f = freelist->min_yield_fraction;
- float collected = freelist->collected;
- float swept = freelist->swept;
- float delta = ((f * swept - collected) / (1.0 - f));
-
-#if 0
- assert (freelist->heap_total_cells >= freelist->collected);
- assert (freelist->swept == freelist->heap_total_cells);
- assert (swept >= collected);
-#endif
-
- return delta;
-}
/* #define DEBUGINFO */
-static int scm_i_minyield_malloc;
-
-void
-scm_gc_init_malloc (void)
-{
- int mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
- SCM_DEFAULT_INIT_MALLOC_LIMIT);
- scm_i_minyield_malloc = scm_getenv_int ("GUILE_MIN_YIELD_MALLOC",
- SCM_DEFAULT_MALLOC_MINYIELD);
-
- if (scm_i_minyield_malloc >= 100)
- scm_i_minyield_malloc = 99;
- if (scm_i_minyield_malloc < 1)
- scm_i_minyield_malloc = 1;
-
- if (mtrigger < 0)
- scm_mtrigger = SCM_DEFAULT_INIT_MALLOC_LIMIT;
- else
- scm_mtrigger = mtrigger;
-}
-
\f
/* Function for non-cell memory management.
if (ptr)
return ptr;
- scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
- scm_gc_running_p = 1;
+ /* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */
+ GC_gcollect ();
- scm_i_gc ("realloc");
-
- /*
- We don't want these sweep statistics to influence results for
- cell GC, so we don't collect statistics.
-
- realloc () failed, so we're really desparate to free memory. Run a
- full sweep.
- */
- scm_i_sweep_all_segments ("realloc", NULL);
-
- scm_gc_running_p = 0;
- scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
-
SCM_SYSCALL (ptr = realloc (mem, size));
if (ptr)
return ptr;
SCM_SYSCALL (ptr = calloc (sz, 1));
if (ptr)
return ptr;
-
+
ptr = scm_realloc (NULL, sz);
memset (ptr, 0x0, sz);
return ptr;
return scm_strndup (str, strlen (str));
}
-static void
-decrease_mtrigger (size_t size, const char * what)
-{
- scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
-
- if (size > scm_mallocated)
- {
- fprintf (stderr, "`scm_mallocated' underflow. This means that more "
- "memory was unregistered\n"
- "via `scm_gc_unregister_collectable_memory ()' than "
- "registered.\n");
- abort ();
- }
-
- scm_mallocated -= size;
- scm_gc_malloc_collected += size;
- scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
-}
-
-static void
-increase_mtrigger (size_t size, const char *what)
-{
- size_t mallocated = 0;
- int overflow = 0, triggered = 0;
-
- scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
- if (ULONG_MAX - size < scm_mallocated)
- overflow = 1;
- else
- {
- scm_mallocated += size;
- mallocated = scm_mallocated;
- if (scm_mallocated > scm_mtrigger)
- triggered = 1;
- }
- scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
-
- if (overflow)
- scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
-
- /*
- A program that uses a lot of malloced collectable memory (vectors,
- strings), will use a lot of memory off the cell-heap; it needs to
- do GC more often (before cells are exhausted), otherwise swapping
- and malloc management will tie it down.
- */
- if (triggered)
- {
- unsigned long prev_alloced;
- float yield;
-
- scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
- scm_gc_running_p = 1;
-
- prev_alloced = mallocated;
-
- /* The GC will finish the pending sweep. For that reason, we
- don't execute a complete sweep after GC, although that might
- free some more memory.
- */
- scm_i_gc (what);
-
- yield = (((float) prev_alloced - (float) scm_mallocated)
- / (float) prev_alloced);
-
- scm_gc_malloc_yield_percentage = (int) (100 * yield);
-
-#ifdef DEBUGINFO
- fprintf (stderr, "prev %lud , now %lud, yield %4.2lf, want %d",
- prev_alloced,
- scm_mallocated,
- 100.0 * yield,
- scm_i_minyield_malloc);
-#endif
-
- if (yield < scm_i_minyield_malloc / 100.0)
- {
- /*
- We make the trigger a little larger, even; If you have a
- program that builds up a lot of data in strings, then the
- desired yield will never be satisfied.
-
- Instead of getting bogged down, we let the mtrigger grow
- strongly with it.
- */
- float no_overflow_trigger = scm_mallocated * 110.0;
-
- no_overflow_trigger /= (float) (100.0 - scm_i_minyield_malloc);
-
-
- if (no_overflow_trigger >= (float) ULONG_MAX)
- scm_mtrigger = ULONG_MAX;
- else
- scm_mtrigger = (unsigned long) no_overflow_trigger;
-
-#ifdef DEBUGINFO
- fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n",
- scm_mtrigger);
-#endif
- }
- scm_gc_running_p = 0;
- scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
- }
-}
void
scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
{
- increase_mtrigger (size, what);
+ /* Nothing to do. */
#ifdef GUILE_DEBUG_MALLOC
if (mem)
- scm_malloc_register (mem, what);
+ scm_malloc_register (mem);
#endif
}
void
scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
{
- decrease_mtrigger (size, what);
+ /* Nothing to do. */
#ifdef GUILE_DEBUG_MALLOC
if (mem)
scm_malloc_unregister (mem);
#endif
}
+/* Allocate SIZE bytes of memory whose contents should not be scanned for
+ pointers (useful, e.g., for strings). */
+void *
+scm_gc_malloc_pointerless (size_t size, const char *what)
+{
+ return GC_MALLOC_ATOMIC (size);
+}
+
void *
scm_gc_malloc (size_t size, const char *what)
{
to write it the program is killed with signal 11. --hwn
*/
- void *ptr = size ? scm_malloc (size) : NULL;
- scm_gc_register_collectable_memory (ptr, size, what);
+ void *ptr;
+
+ if (size == 0)
+ /* `GC_MALLOC ()' doesn't handle zero. */
+ size = sizeof (void *);
+
+ ptr = GC_MALLOC (size);
+
return ptr;
}
void *
scm_gc_calloc (size_t size, const char *what)
{
- void *ptr = scm_gc_malloc (size, what);
- memset (ptr, 0x0, size);
- return ptr;
+ /* `GC_MALLOC ()' always returns a zeroed buffer. */
+ return scm_gc_malloc (size, what);
}
{
void *ptr;
- /* XXX - see scm_gc_malloc. */
-
-
- /*
- scm_realloc () may invalidate the block pointed to by WHERE, eg. by
- unmapping it from memory or altering the contents. Since
- increase_mtrigger () might trigger a GC that would scan
- MEM, it is crucial that this call precedes realloc ().
- */
-
- decrease_mtrigger (old_size, what);
- increase_mtrigger (new_size, what);
-
- ptr = scm_realloc (mem, new_size);
+ ptr = GC_REALLOC (mem, new_size);
#ifdef GUILE_DEBUG_MALLOC
if (mem)
scm_malloc_reregister (mem, ptr, what);
#endif
-
+
return ptr;
}
scm_gc_free (void *mem, size_t size, const char *what)
{
scm_gc_unregister_collectable_memory (mem, size, what);
- if (mem)
- free (mem);
+ GC_FREE (mem);
}
char *
scm_gc_strndup (const char *str, size_t n, const char *what)
{
- char *dst = scm_gc_malloc (n+1, what);
+ char *dst = GC_MALLOC_ATOMIC (n + 1);
memcpy (dst, str, n);
dst[n] = 0;
return dst;
#ifdef GUILE_DEBUG_MALLOC
scm_malloc_unregister (obj);
#endif
- if (obj)
- free (obj);
- else
- {
- fprintf (stderr,"freeing NULL pointer");
- abort ();
- }
+
+ free (obj);
}
#undef FUNC_NAME
+++ /dev/null
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2009 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
- */
-
-
-\f
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <stdio.h>
-#include <errno.h>
-#include <string.h>
-#include <assert.h>
-
-#ifdef __ia64__
-#include <ucontext.h>
-extern unsigned long * __libc_ia64_register_backing_store_base;
-#endif
-
-#include "libguile/_scm.h"
-#include "libguile/eval.h"
-#include "libguile/stime.h"
-#include "libguile/stackchk.h"
-#include "libguile/struct.h"
-#include "libguile/smob.h"
-#include "libguile/arrays.h"
-#include "libguile/async.h"
-#include "libguile/programs.h"
-#include "libguile/ports.h"
-#include "libguile/root.h"
-#include "libguile/strings.h"
-#include "libguile/vectors.h"
-#include "libguile/weaks.h"
-#include "libguile/hashtab.h"
-#include "libguile/tags.h"
-#include "libguile/private-gc.h"
-#include "libguile/validate.h"
-#include "libguile/deprecation.h"
-#include "libguile/gc.h"
-#include "libguile/guardians.h"
-
-#ifdef GUILE_DEBUG_MALLOC
-#include "libguile/debug-malloc.h"
-#endif
-
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-int scm_i_marking = 0;
-
-/*
- Entry point for this file.
- */
-void
-scm_mark_all (void)
-{
- long j;
- int loops;
-
- scm_i_marking = 1;
- scm_i_init_weak_vectors_for_gc ();
- scm_i_init_guardians_for_gc ();
-
- scm_i_clear_mark_space ();
- scm_i_find_heap_calls = 0;
- /* Mark every thread's stack and registers */
- scm_threads_mark_stacks ();
-
- j = SCM_NUM_PROTECTS;
- while (j--)
- scm_gc_mark (scm_sys_protects[j]);
-
- /* mark the registered roots */
- {
- size_t i;
- for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots); ++i)
- {
- SCM l = SCM_HASHTABLE_BUCKET (scm_gc_registered_roots, i);
- for (; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM *p = (SCM *) (scm_to_ulong (SCM_CAAR (l)));
- scm_gc_mark (*p);
- }
- }
- }
-
- loops = 0;
- while (1)
- {
- int again;
- loops++;
-
- /* Mark the non-weak references of weak vectors. For a weak key
- alist vector, this would mark the values for keys that are
- marked. We need to do this in a loop until everything
- settles down since the newly marked values might be keys in
- other weak key alist vectors, for example.
- */
- again = scm_i_mark_weak_vectors_non_weaks ();
- if (again)
- continue;
-
- /* Now we scan all marked guardians and move all unmarked objects
- from the accessible to the inaccessible list.
- */
- scm_i_identify_inaccessible_guardeds ();
-
- /* When we have identified all inaccessible objects, we can mark
- them.
- */
- again = scm_i_mark_inaccessible_guardeds ();
-
- /* This marking might have changed the situation for weak vectors
- and might have turned up new guardians that need to be processed,
- so we do it all over again.
- */
- if (again)
- continue;
-
- /* Nothing new marked in this round, we are done.
- */
- break;
- }
-
- /* Remove all unmarked entries from the weak vectors.
- */
- scm_i_remove_weaks_from_weak_vectors ();
-
- /* Bring hashtables upto date.
- */
- scm_i_scan_weak_hashtables ();
- scm_i_marking = 0;
-}
-
-/* {Mark/Sweep}
- */
-
-/*
- Mark an object precisely, then recurse.
- */
-void
-scm_gc_mark (SCM ptr)
-{
- if (SCM_IMP (ptr))
- return;
-
- if (SCM_GC_MARK_P (ptr))
- return;
-
- if (!scm_i_marking)
- {
- static const char msg[]
- = "Should only call scm_gc_mark() during GC.";
- scm_c_issue_deprecation_warning (msg);
- }
-
- SCM_SET_GC_MARK (ptr);
- scm_gc_mark_dependencies (ptr);
-}
-
-void
-scm_i_ensure_marking (void)
-{
- assert (scm_i_marking);
-}
-
-/*
-
-Mark the dependencies of an object.
-
-Prefetching:
-
-Should prefetch objects before marking, i.e. if marking a cell, we
-should prefetch the car, and then mark the cdr. This will improve CPU
-cache misses, because the car is more likely to be in cache when we
-finish the cdr.
-
-See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
-garbage collector cache misses.
-
-Prefetch is supported on GCC >= 3.1
-
-(Some time later.)
-
-Tried this with GCC 3.1.1 -- the time differences are barely measurable.
-Perhaps this would work better with an explicit markstack?
-
-
-*/
-
-void
-scm_gc_mark_dependencies (SCM p)
-#define FUNC_NAME "scm_gc_mark_dependencies"
-{
- register long i;
- register SCM ptr;
- SCM cell_type;
-
- ptr = p;
- scm_mark_dependencies_again:
-
- cell_type = SCM_GC_CELL_TYPE (ptr);
- switch (SCM_ITAG7 (cell_type))
- {
- case scm_tcs_cons_nimcar:
- if (SCM_IMP (SCM_CDR (ptr)))
- {
- ptr = SCM_CAR (ptr);
- goto gc_mark_nimp;
- }
-
-
- scm_gc_mark (SCM_CAR (ptr));
- ptr = SCM_CDR (ptr);
- goto gc_mark_nimp;
- case scm_tcs_cons_imcar:
- ptr = SCM_CDR (ptr);
- goto gc_mark_loop;
- case scm_tc7_pws:
-
- scm_gc_mark (SCM_SETTER (ptr));
- ptr = SCM_PROCEDURE (ptr);
- goto gc_mark_loop;
- case scm_tcs_struct:
- {
- /* XXX - use less explicit code. */
- scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
- scm_t_bits * vtable_data = (scm_t_bits *) word0;
- SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
- long len = scm_i_symbol_length (layout);
- scm_t_bits *struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
-
- if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
- {
- scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
- scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
- }
- if (len)
- {
- long x;
-
- for (x = 0; x < len - 2; x += 2, ++struct_data)
- if (scm_i_symbol_ref (layout, x) == 'p')
- scm_gc_mark (SCM_PACK (*struct_data));
- if (scm_i_symbol_ref (layout, x) == 'p')
- {
- scm_t_wchar ch = scm_i_symbol_ref (layout, x+1);
- if (SCM_LAYOUT_TAILP (ch))
- for (x = *struct_data++; x; --x, ++struct_data)
- scm_gc_mark (SCM_PACK (*struct_data));
- else
- scm_gc_mark (SCM_PACK (*struct_data));
- }
- }
- /* mark vtable */
- ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
- goto gc_mark_loop;
- }
- break;
- case scm_tcs_closures:
- if (SCM_IMP (SCM_ENV (ptr)))
- {
- ptr = SCM_CLOSCAR (ptr);
- goto gc_mark_nimp;
- }
- scm_gc_mark (SCM_CLOSCAR (ptr));
- ptr = SCM_ENV (ptr);
- goto gc_mark_nimp;
- case scm_tc7_program:
- if (SCM_PROGRAM_FREE_VARIABLES (ptr) != SCM_BOOL_F)
- scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (ptr));
- if (SCM_PROGRAM_OBJTABLE (ptr) != SCM_BOOL_F)
- scm_gc_mark (SCM_PROGRAM_OBJTABLE (ptr));
- ptr = SCM_PROGRAM_OBJCODE (ptr);
- goto gc_mark_nimp;
- case scm_tc7_vector:
- i = SCM_SIMPLE_VECTOR_LENGTH (ptr);
- if (i == 0)
- break;
- while (--i > 0)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (ptr, i);
- if (SCM_NIMP (elt))
- scm_gc_mark (elt);
- }
- ptr = SCM_SIMPLE_VECTOR_REF (ptr, 0);
- goto gc_mark_loop;
-
- case scm_tc7_string:
- ptr = scm_i_string_mark (ptr);
- goto gc_mark_loop;
- case scm_tc7_stringbuf:
- ptr = scm_i_stringbuf_mark (ptr);
- goto gc_mark_loop;
-
- case scm_tc7_number:
- if (SCM_TYP16 (ptr) == scm_tc16_fraction)
- {
- scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
- ptr = SCM_CELL_OBJECT_2 (ptr);
- goto gc_mark_loop;
- }
- break;
-
- case scm_tc7_wvect:
- scm_i_mark_weak_vector (ptr);
- break;
-
- case scm_tc7_symbol:
- ptr = scm_i_symbol_mark (ptr);
- goto gc_mark_loop;
- case scm_tc7_variable:
- ptr = SCM_CELL_OBJECT_1 (ptr);
- goto gc_mark_loop;
- case scm_tcs_subrs:
- if (SCM_CELL_WORD_2 (ptr) && *(SCM*)SCM_CELL_WORD_2 (ptr))
- /* the generic associated with this primitive */
- scm_gc_mark (*(SCM*)SCM_CELL_WORD_2 (ptr));
- if (SCM_NIMP (((SCM*)SCM_CELL_WORD_3 (ptr))[1]))
- scm_gc_mark (((SCM*)SCM_CELL_WORD_3 (ptr))[1]); /* props */
- ptr = ((SCM*)SCM_CELL_WORD_3 (ptr))[0]; /* name */
- goto gc_mark_loop;
- case scm_tc7_port:
- i = SCM_PTOBNUM (ptr);
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (!(i < scm_numptob))
- {
- fprintf (stderr, "undefined port type");
- abort ();
- }
-#endif
- if (SCM_PTAB_ENTRY (ptr))
- scm_gc_mark (SCM_FILENAME (ptr));
- if (scm_ptobs[i].mark)
- {
- ptr = (scm_ptobs[i].mark) (ptr);
- goto gc_mark_loop;
- }
- else
- return;
- break;
- case scm_tc7_smob:
- switch (SCM_TYP16 (ptr))
- { /* should be faster than going through scm_smobs */
- case scm_tc_free_cell:
- /* We have detected a free cell. This can happen if non-object data
- * on the C stack points into guile's heap and is scanned during
- * conservative marking. */
- break;
- default:
- i = SCM_SMOBNUM (ptr);
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (!(i < scm_numsmob))
- {
- fprintf (stderr, "undefined smob type");
- abort ();
- }
-#endif
- if (scm_smobs[i].mark)
- {
- ptr = (scm_smobs[i].mark) (ptr);
- goto gc_mark_loop;
- }
- else
- return;
- }
- break;
- default:
- fprintf (stderr, "unknown type");
- abort ();
- }
-
- /*
- If we got here, then exhausted recursion options for PTR. we
- return (careful not to mark PTR, it might be the argument that we
- were called with.)
- */
- return ;
-
- gc_mark_loop:
- if (SCM_IMP (ptr))
- return;
-
- gc_mark_nimp:
- {
- int valid_cell = CELL_P (ptr);
-
-
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_debug_cell_accesses_p)
- {
- /* We are in debug mode. Check the ptr exhaustively. */
-
- valid_cell = valid_cell && scm_in_heap_p (ptr);
- }
-
-#endif
- if (!valid_cell)
- {
- fprintf (stderr, "rogue pointer in heap");
- abort ();
- }
- }
-
- if (SCM_GC_MARK_P (ptr))
- return;
-
- SCM_SET_GC_MARK (ptr);
-
- goto scm_mark_dependencies_again;
-
-}
-#undef FUNC_NAME
-
-
-/* Mark a region conservatively */
-void
-scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
-{
- unsigned long m;
-
- for (m = 0; m < n; ++m)
- {
- SCM obj = * (SCM *) &x[m];
- long int segment = scm_i_find_heap_segment_containing_object (obj);
- if (segment >= 0)
- scm_gc_mark (obj);
- }
-}
-
-
-/* The function scm_in_heap_p determines whether an SCM value can be regarded as a
- * pointer to a cell on the heap.
- */
-int
-scm_in_heap_p (SCM value)
-{
- long int segment = scm_i_find_heap_segment_containing_object (value);
- return (segment >= 0);
-}
-
-
-#if SCM_ENABLE_DEPRECATED == 1
-
-/* If an allocated cell is detected during garbage collection, this
- * means that some code has just obtained the object but was preempted
- * before the initialization of the object was completed. This meanst
- * that some entries of the allocated cell may already contain SCM
- * objects. Therefore, allocated cells are scanned conservatively.
- */
-
-scm_t_bits scm_tc16_allocated;
-
-static SCM
-allocated_mark (SCM cell)
-{
- unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
- unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
- unsigned int i;
-
- for (i = 1; i != span * 2; ++i)
- {
- SCM obj = SCM_CELL_OBJECT (cell, i);
- long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
- if (obj_segment >= 0)
- scm_gc_mark (obj);
- }
- return SCM_BOOL_F;
-}
-
-SCM
-scm_deprecated_newcell (void)
-{
- scm_c_issue_deprecation_warning
- ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n");
-
- return scm_cell (scm_tc16_allocated, 0);
-}
-
-SCM
-scm_deprecated_newcell2 (void)
-{
- scm_c_issue_deprecation_warning
- ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n");
-
- return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
-}
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
-
-void
-scm_gc_init_mark (void)
-{
-#if SCM_ENABLE_DEPRECATED == 1
- scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
- scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
-#endif
-}
-
+++ /dev/null
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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 <assert.h>
-#include <stdio.h>
-#include <string.h>
-
-#include "libguile/_scm.h"
-#include "libguile/pairs.h"
-#include "libguile/gc.h"
-#include "libguile/private-gc.h"
-
-
-/*
- Heap segment table.
-
- The table is sorted by the address of the data itself. This makes
- for easy lookups. This is not portable: according to ANSI C,
- pointers can only be compared within the same object (i.e. the same
- block of malloced memory.). For machines with weird architectures,
- this should be revised.
-
- (Apparently, for this reason 1.6 and earlier had macros for pointer
- comparison. )
-
- perhaps it is worthwhile to remove the 2nd level of indirection in
- the table, but this certainly makes for cleaner code.
-*/
-scm_t_heap_segment **scm_i_heap_segment_table;
-size_t scm_i_heap_segment_table_size;
-static scm_t_cell *lowest_cell;
-static scm_t_cell *highest_cell;
-
-
-/*
- RETURN: index of inserted segment.
- */
-int
-scm_i_insert_segment (scm_t_heap_segment *seg)
-{
- size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
- SCM_SYSCALL (scm_i_heap_segment_table
- = ((scm_t_heap_segment **)
- realloc ((char *)scm_i_heap_segment_table, size)));
-
- /*
- We can't alloc 4 more bytes. This is hopeless.
- */
- if (!scm_i_heap_segment_table)
- {
- fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
- abort ();
- }
-
- if (!lowest_cell)
- {
- lowest_cell = seg->bounds[0];
- highest_cell = seg->bounds[1];
- }
- else
- {
- lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
- highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
- }
-
-
- {
- int i = 0;
- int j = 0;
-
- while (i < scm_i_heap_segment_table_size
- && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
- i++;
-
- /*
- We insert a new entry; if that happens to be before the
- "current" segment of a freelist, we must move the freelist index
- as well.
- */
- if (scm_i_master_freelist.heap_segment_idx >= i)
- scm_i_master_freelist.heap_segment_idx ++;
- if (scm_i_master_freelist2.heap_segment_idx >= i)
- scm_i_master_freelist2.heap_segment_idx ++;
-
- for (j = scm_i_heap_segment_table_size; j > i; --j)
- scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];
-
- scm_i_heap_segment_table[i] = seg;
- scm_i_heap_segment_table_size ++;
-
- return i;
- }
-}
-
-
-/*
- Determine whether the given value does actually represent a cell in
- some heap segment. If this is the case, the number of the heap
- segment is returned. Otherwise, -1 is returned. Binary search is
- used to determine the heap segment that contains the cell.
-
- I think this function is too long to be inlined. --hwn
-*/
-
-int
-scm_i_find_heap_segment_containing_object (SCM obj)
-{
- if (!CELL_P (obj))
- return -1;
-
- scm_i_find_heap_calls ++;
- if ((scm_t_cell *) obj < lowest_cell || (scm_t_cell *) obj >= highest_cell)
- return -1;
-
- {
- scm_t_cell *ptr = SCM2PTR (obj);
- unsigned int i = 0;
- unsigned int j = scm_i_heap_segment_table_size - 1;
-
- if (ptr < scm_i_heap_segment_table[i]->bounds[0])
- return -1;
- else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
- return -1;
- else
- {
- while (i < j)
- {
- if (ptr < scm_i_heap_segment_table[i]->bounds[1])
- {
- break;
- }
- else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
- {
- i = j;
- break;
- }
- else
- {
- unsigned long int k = (i + j) / 2;
-
- if (k == i)
- return -1;
- else if (ptr < scm_i_heap_segment_table[k]->bounds[1])
- {
- j = k;
- ++i;
- if (ptr < scm_i_heap_segment_table[i]->bounds[0])
- return -1;
- }
- else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
- {
- i = k;
- --j;
- if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
- return -1;
- }
- }
- }
-
- if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
- return -1;
- else if (SCM_GC_IN_CARD_HEADERP (ptr))
- return -1;
- else
- return i;
- }
- }
-}
-
-
-int
-scm_i_marked_count (void)
-{
- int i = 0;
- int c = 0;
- for (; i < scm_i_heap_segment_table_size; i++)
- {
- c += scm_i_heap_segment_marked_count (scm_i_heap_segment_table[i]);
- }
- return c;
-}
-
-
-SCM
-scm_i_sweep_some_segments (scm_t_cell_type_statistics *freelist,
- scm_t_sweep_statistics *sweep_stats)
-{
- int i = freelist->heap_segment_idx;
- SCM collected = SCM_EOL;
-
- if (i == -1) /* huh? --hwn */
- i++;
-
- for (;
- i < scm_i_heap_segment_table_size; i++)
- {
- if (scm_i_heap_segment_table[i]->freelist != freelist)
- continue;
-
- collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i],
- sweep_stats,
- DEFAULT_SWEEP_AMOUNT);
-
- if (collected != SCM_EOL) /* Don't increment i */
- break;
- }
-
- freelist->heap_segment_idx = i;
-
- return collected;
-}
-
-void
-scm_i_reset_segments (void)
-{
- int i = 0;
- for (; i < scm_i_heap_segment_table_size; i++)
- {
- scm_t_heap_segment *seg = scm_i_heap_segment_table[i];
- seg->next_free_card = seg->bounds[0];
- }
-}
-
-
-
-
-/*
- Return a hashtab with counts of live objects, with tags as keys.
- */
-SCM
-scm_i_all_segments_statistics (SCM tab)
-{
- int i = 0;
- for (; i < scm_i_heap_segment_table_size; i++)
- {
- scm_t_heap_segment *seg = scm_i_heap_segment_table[i];
- scm_i_heap_segment_statistics (seg, tab);
- }
-
- return tab;
-}
-
-
-unsigned long*
-scm_i_segment_table_info (int* size)
-{
- *size = scm_i_heap_segment_table_size;
- unsigned long *bounds = malloc (sizeof (unsigned long) * *size * 2);
- int i;
- if (!bounds)
- abort ();
- for (i = *size; i-- > 0; )
- {
- bounds[2*i] = (unsigned long)scm_i_heap_segment_table[i]->bounds[0];
- bounds[2*i+1] = (unsigned long)scm_i_heap_segment_table[i]->bounds[1];
- }
- return bounds;
-}
-
-
-void
-scm_i_sweep_all_segments (char const *reason,
- scm_t_sweep_statistics *sweep_stats)
-{
- unsigned i= 0;
- for (i = 0; i < scm_i_heap_segment_table_size; i++)
- {
- scm_i_sweep_segment (scm_i_heap_segment_table[i], sweep_stats);
- }
-}
-
-
-void
-scm_i_clear_mark_space (void)
-{
- int i = 0;
- for (; i < scm_i_heap_segment_table_size; i++)
- {
- scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
- }
-}
+++ /dev/null
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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 <assert.h>
-#include <stdio.h>
-#include <string.h>
-
-#include <count-one-bits.h>
-
-#include "libguile/_scm.h"
-#include "libguile/pairs.h"
-#include "libguile/gc.h"
-#include "libguile/private-gc.h"
-
-size_t scm_max_segment_size;
-
-/* Important entry point: try to grab some memory, and make it into a
- segment; return the index of the segment. SWEEP_STATS should contain
- global GC sweep statistics collected since the last full GC.
-
- Returns the index of the segment. If error_policy !=
- abort_on_error, we return -1 on failure.
-*/
-int
-scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
- size_t len,
- policy_on_error error_policy)
-{
- if (len > scm_max_segment_size)
- len = scm_max_segment_size;
-
- if (len < SCM_MIN_HEAP_SEG_SIZE)
- len = SCM_MIN_HEAP_SEG_SIZE;
-
- /* todo: consider having a more flexible lower bound. */
- {
- scm_t_heap_segment *seg = scm_i_make_empty_heap_segment (freelist);
-
- /* Allocate with decaying ambition. */
- while (len >= SCM_MIN_HEAP_SEG_SIZE)
- {
- if (scm_i_initialize_heap_segment_data (seg, len))
- return scm_i_insert_segment (seg);
-
- len /= 2;
- }
- }
-
- if (error_policy == abort_on_error)
- {
- fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
- abort ();
- }
- return -1;
-}
-
-
-scm_t_heap_segment *
-scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl)
-{
- scm_t_heap_segment *shs = calloc (1, sizeof (scm_t_heap_segment));
-
- if (!shs)
- {
- fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n");
- abort ();
- }
-
- shs->span = fl->span;
- shs->freelist = fl;
-
- return shs;
-}
-
-void
-scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab)
-{
- scm_t_cell *p = seg->bounds[0];
- while (p < seg->bounds[1])
- {
- scm_i_card_statistics (p, tab, seg);
- p += SCM_GC_CARD_N_CELLS;
- }
-}
-
-/*
- count number of marked bits, so we know how much cells are live.
- */
-int
-scm_i_heap_segment_marked_count (scm_t_heap_segment *seg)
-{
- scm_t_c_bvec_long *bvec = (scm_t_c_bvec_long *) seg->bounds[1];
- scm_t_c_bvec_long *bvec_end =
- (bvec +
- scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS);
-
- int count = 0;
- while (bvec < bvec_end)
- {
- count += count_one_bits_l (*bvec);
- bvec ++;
- }
- return count * seg->span;
-}
-
-int
-scm_i_segment_card_number (scm_t_heap_segment *seg,
- scm_t_cell *card)
-{
- return (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
-}
-
-/*
- Fill SEGMENT with memory both for data and mark bits.
-
- RETURN: 1 on success, 0 failure
- */
-int
-scm_i_initialize_heap_segment_data (scm_t_heap_segment *segment, size_t requested)
-{
- /*
- round upwards
- */
- int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
- int card_count = 1 + (requested / sizeof (scm_t_cell)) / card_data_cell_count;
-
- /*
- one card extra due to alignment
- */
- size_t mem_needed = (1 + card_count) * SCM_GC_SIZEOF_CARD
- + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG;
- scm_t_cell *memory = 0;
-
- /*
- We use calloc to alloc the heap, so it is nicely initialized.
- */
- SCM_SYSCALL (memory = (scm_t_cell *) calloc (1, mem_needed));
-
- if (memory == NULL)
- return 0;
-
- segment->malloced = memory;
- segment->bounds[0] = SCM_GC_CARD_UP (memory);
- segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS;
- segment->freelist->heap_total_cells += scm_i_segment_cell_count (segment);
-
- /*
- Don't init the mem or the bitvector. This is handled by lazy
- sweeping.
- */
- segment->next_free_card = segment->bounds[0];
- segment->first_time = 1;
- return 1;
-}
-
-int
-scm_i_segment_card_count (scm_t_heap_segment *seg)
-{
- return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
-}
-
-/*
- Return the number of available single-cell data cells.
- */
-int
-scm_i_segment_cell_count (scm_t_heap_segment *seg)
-{
- return scm_i_segment_card_count (seg)
- * scm_i_segment_cells_per_card (seg);
-}
-
-int
-scm_i_segment_cells_per_card (scm_t_heap_segment *seg)
-{
- return (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS
- + ((seg->span == 2) ? -1 : 0));
-}
-
-void
-scm_i_clear_segment_mark_space (scm_t_heap_segment *seg)
-{
- scm_t_cell *markspace = seg->bounds[1];
-
- memset (markspace, 0x00,
- scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG);
-}
-
-
-/*
- Force a sweep of this entire segment.
- */
-void
-scm_i_sweep_segment (scm_t_heap_segment *seg,
- scm_t_sweep_statistics *sweep_stats)
-{
- int infinity = 1 << 30;
- scm_t_cell *remember = seg->next_free_card;
- while (scm_i_sweep_some_cards (seg, sweep_stats, infinity) != SCM_EOL)
- ;
- seg->next_free_card = remember;
-}
-
-
-/* Sweep cards from SEG until we've gathered THRESHOLD cells. On
- return, SWEEP_STATS, if non-NULL, contains the number of cells that
- have been visited and collected. A freelist is returned,
- potentially empty. */
-SCM
-scm_i_sweep_some_cards (scm_t_heap_segment *seg,
- scm_t_sweep_statistics *sweep_stats,
- int threshold)
-{
- SCM cells = SCM_EOL;
- int collected = 0;
- int (*sweeper) (scm_t_cell *, SCM *, scm_t_heap_segment *)
- = (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card;
-
- scm_t_cell *next_free = seg->next_free_card;
- int cards_swept = 0;
- while (collected < threshold && next_free < seg->bounds[1])
- {
- collected += (*sweeper) (next_free, &cells, seg);
- next_free += SCM_GC_CARD_N_CELLS;
- cards_swept ++;
- }
-
- if (sweep_stats != NULL)
- {
- int swept = cards_swept
- * ((SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
- - seg->span + 1);
- int collected_cells = collected * seg->span;
- sweep_stats->swept += swept;
- sweep_stats->collected += collected_cells;
- }
-
- if (next_free == seg->bounds[1])
- {
- seg->first_time = 0;
- }
-
- seg->next_free_card = next_free;
- return cells;
-}
-
-
-
-SCM
-scm_i_sweep_for_freelist (scm_t_cell_type_statistics *freelist)
-{
- scm_t_sweep_statistics stats = { 0 };
- SCM result = scm_i_sweep_some_segments (freelist, &stats);
-
- scm_i_gc_sweep_stats.collected += stats.collected;
- scm_i_gc_sweep_stats.swept += stats.swept;
-
- freelist->collected += stats.collected;
- freelist->swept += stats.swept;
- return result;
-}
-
# include <config.h>
#endif
+#include "libguile/gen-scmconfig.h"
+
#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <assert.h>
+#ifdef __ia64__
+#include <ucontext.h>
+extern unsigned long * __libc_ia64_register_backing_store_base;
+#endif
+
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/stime.h"
#include "libguile/gc.h"
#include "libguile/dynwind.h"
+#include "libguile/bdw-gc.h"
+
#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif
*/
int scm_i_cell_validation_already_running ;
+static SCM protects;
+
+
#if (SCM_DEBUG_CELL_ACCESSES == 1)
void
scm_i_expensive_validation_check (SCM cell)
{
- if (!scm_in_heap_p (cell))
- {
- fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
- (unsigned long) SCM_UNPACK (cell));
- abort ();
- }
-
/* If desired, perform additional garbage collections after a user
* defined number of cell accesses.
*/
*/
if (scm_expensive_debug_cell_accesses_p)
scm_i_expensive_validation_check (cell);
-#if (SCM_DEBUG_MARKING_API == 0)
- if (!SCM_GC_MARK_P (cell))
- {
- fprintf (stderr,
- "scm_assert_cell_valid: this object is unmarked. \n"
- "It has been garbage-collected in the last GC run: "
- "%lux\n",
- (unsigned long) SCM_UNPACK (cell));
- abort ();
- }
-#endif /* SCM_DEBUG_MARKING_API */
-
+
scm_i_cell_validation_already_running = 0; /* re-enable */
}
}
#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
\f
+/* Hooks. */
+scm_t_c_hook scm_before_gc_c_hook;
+scm_t_c_hook scm_before_mark_c_hook;
+scm_t_c_hook scm_before_sweep_c_hook;
+scm_t_c_hook scm_after_sweep_c_hook;
+scm_t_c_hook scm_after_gc_c_hook;
-/* scm_mtrigger
- * is the number of bytes of malloc allocation needed to trigger gc.
- */
-unsigned long scm_mtrigger;
-
/* GC Statistics Keeping
*/
-unsigned long scm_cells_allocated = 0;
-unsigned long scm_last_cells_allocated = 0;
-unsigned long scm_mallocated = 0;
-long int scm_i_find_heap_calls = 0;
-/* Global GC sweep statistics since the last full GC. */
-scm_t_sweep_statistics scm_i_gc_sweep_stats = { 0, 0 };
-
-/* Total count of cells marked/swept. */
-static double scm_gc_cells_marked_acc = 0.;
-static double scm_gc_cells_marked_conservatively_acc = 0.;
-static double scm_gc_cells_swept_acc = 0.;
-static double scm_gc_cells_allocated_acc = 0.;
+unsigned long scm_gc_ports_collected = 0;
-static unsigned long scm_gc_time_taken = 0;
-static unsigned long scm_gc_mark_time_taken = 0;
-
-static unsigned long scm_gc_times = 0;
-
-static int scm_gc_cell_yield_percentage = 0;
static unsigned long protected_obj_count = 0;
-/* The following are accessed from `gc-malloc.c' and `gc-card.c'. */
-int scm_gc_malloc_yield_percentage = 0;
-unsigned long scm_gc_malloc_collected = 0;
-
SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
-SCM_SYMBOL (sym_heap_size, "cell-heap-size");
+SCM_SYMBOL (sym_heap_size, "heap-size");
+SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
+SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
SCM_SYMBOL (sym_mallocated, "bytes-malloced");
SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
SCM tab = scm_make_hash_table (scm_from_int (57));
SCM alist;
- scm_i_all_segments_statistics (tab);
-
alist
= scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab);
"use of storage.\n")
#define FUNC_NAME s_scm_gc_stats
{
- long i = 0;
- SCM heap_segs = SCM_EOL ;
- unsigned long int local_scm_mtrigger;
- unsigned long int local_scm_mallocated;
- unsigned long int local_scm_heap_size;
- int local_scm_gc_cell_yield_percentage;
- int local_scm_gc_malloc_yield_percentage;
- unsigned long int local_scm_cells_allocated;
- unsigned long int local_scm_gc_time_taken;
- unsigned long int local_scm_gc_times;
- unsigned long int local_scm_gc_mark_time_taken;
- unsigned long int local_protected_obj_count;
- double local_scm_gc_cells_swept;
- double local_scm_gc_cells_marked;
- double local_scm_gc_cells_marked_conservatively;
- double local_scm_total_cells_allocated;
SCM answer;
- unsigned long *bounds = 0;
- int table_size = 0;
- SCM_CRITICAL_SECTION_START;
+ size_t heap_size, free_bytes, bytes_since_gc, total_bytes;
+ size_t gc_times;
- bounds = scm_i_segment_table_info (&table_size);
-
- /* Below, we cons to produce the resulting list. We want a snapshot of
- * the heap situation before consing.
- */
- local_scm_mtrigger = scm_mtrigger;
- local_scm_mallocated = scm_mallocated;
- local_scm_heap_size =
- (scm_i_master_freelist.heap_total_cells + scm_i_master_freelist2.heap_total_cells);
+ heap_size = GC_get_heap_size ();
+ free_bytes = GC_get_free_bytes ();
+ bytes_since_gc = GC_get_bytes_since_gc ();
+ total_bytes = GC_get_total_bytes ();
+ gc_times = GC_gc_no;
- local_scm_cells_allocated =
- scm_cells_allocated + scm_i_gc_sweep_stats.collected;
-
- local_scm_gc_time_taken = scm_gc_time_taken;
- local_scm_gc_mark_time_taken = scm_gc_mark_time_taken;
- local_scm_gc_times = scm_gc_times;
- local_scm_gc_malloc_yield_percentage = scm_gc_malloc_yield_percentage;
- local_scm_gc_cell_yield_percentage = scm_gc_cell_yield_percentage;
- local_protected_obj_count = protected_obj_count;
- local_scm_gc_cells_swept =
- (double) scm_gc_cells_swept_acc
- + (double) scm_i_gc_sweep_stats.swept;
- local_scm_gc_cells_marked = scm_gc_cells_marked_acc
- + (double) scm_i_gc_sweep_stats.swept
- - (double) scm_i_gc_sweep_stats.collected;
- local_scm_gc_cells_marked_conservatively
- = scm_gc_cells_marked_conservatively_acc;
-
- local_scm_total_cells_allocated = scm_gc_cells_allocated_acc
- + (double) scm_i_gc_sweep_stats.collected;
-
- for (i = table_size; i--;)
- {
- heap_segs = scm_cons (scm_cons (scm_from_ulong (bounds[2*i]),
- scm_from_ulong (bounds[2*i+1])),
- heap_segs);
- }
-
/* njrev: can any of these scm_cons's or scm_list_n signal a memory
error? If so we need a frame here. */
answer =
- scm_list_n (scm_cons (sym_gc_time_taken,
- scm_from_ulong (local_scm_gc_time_taken)),
+ scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0),
+#if 0
scm_cons (sym_cells_allocated,
scm_from_ulong (local_scm_cells_allocated)),
- scm_cons (sym_total_cells_allocated,
- scm_from_double (local_scm_total_cells_allocated)),
- scm_cons (sym_heap_size,
- scm_from_ulong (local_scm_heap_size)),
- scm_cons (sym_cells_marked_conservatively,
- scm_from_ulong (local_scm_gc_cells_marked_conservatively)),
scm_cons (sym_mallocated,
scm_from_ulong (local_scm_mallocated)),
scm_cons (sym_mtrigger,
scm_from_ulong (local_scm_mtrigger)),
- scm_cons (sym_times,
- scm_from_ulong (local_scm_gc_times)),
scm_cons (sym_gc_mark_time_taken,
scm_from_ulong (local_scm_gc_mark_time_taken)),
scm_cons (sym_cells_marked,
scm_from_long (local_scm_gc_malloc_yield_percentage)),
scm_cons (sym_cell_yield,
scm_from_long (local_scm_gc_cell_yield_percentage)),
- scm_cons (sym_protected_objects,
- scm_from_ulong (local_protected_obj_count)),
scm_cons (sym_heap_segments, heap_segs),
+#endif
+ scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
+ scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
+ scm_cons (sym_heap_total_allocated,
+ scm_from_size_t (total_bytes)),
+ scm_cons (sym_protected_objects,
+ scm_from_ulong (protected_obj_count)),
+ scm_cons (sym_times, scm_from_size_t (gc_times)),
SCM_UNDEFINED);
- SCM_CRITICAL_SECTION_END;
-
- free (bounds);
+
return answer;
}
#undef FUNC_NAME
-/*
- Update nice-to-know-statistics.
- */
-static void
-gc_end_stats ()
+
+SCM_DEFINE (scm_gc_dump, "gc-dump", 0, 0, 0,
+ (void),
+ "Dump information about the garbage collector's internal data "
+ "structures and memory usage to the standard output.")
+#define FUNC_NAME s_scm_gc_dump
{
- /* CELLS SWEPT is another word for the number of cells that were examined
- during GC. YIELD is the number that we cleaned out. MARKED is the number
- that weren't cleaned. */
- scm_gc_cell_yield_percentage = (scm_i_gc_sweep_stats.collected * 100) /
- (scm_i_master_freelist.heap_total_cells + scm_i_master_freelist2.heap_total_cells);
-
- scm_gc_cells_allocated_acc +=
- (double) scm_i_gc_sweep_stats.collected;
- scm_gc_cells_marked_acc += (double) scm_i_last_marked_cell_count;
- scm_gc_cells_marked_conservatively_acc += (double) scm_i_find_heap_calls;
- scm_gc_cells_swept_acc += (double) scm_i_gc_sweep_stats.swept;
-
- ++scm_gc_times;
+ GC_dump ();
+
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
(SCM obj),
#undef FUNC_NAME
+SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0,
+ (),
+ "Disables the garbage collector. Nested calls are permitted. "
+ "GC is re-enabled once @code{gc-enable} has been called the "
+ "same number of times @code{gc-disable} was called.")
+#define FUNC_NAME s_scm_gc_disable
+{
+ GC_disable ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0,
+ (),
+ "Enables the garbage collector.")
+#define FUNC_NAME s_scm_gc_enable
+{
+ GC_enable ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
(),
"Scans all of SCM objects and reclaims for further use those that are\n"
#define FUNC_NAME s_scm_gc
{
scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
- scm_gc_running_p = 1;
scm_i_gc ("call");
/* njrev: It looks as though other places, e.g. scm_realloc,
can call scm_i_gc without acquiring the sweep mutex. Does this
(e.g. scm_permobjs above in scm_gc_stats) by a critical section,
not by the sweep mutex. Shouldn't all the GC-relevant objects be
protected in the same way? */
- scm_gc_running_p = 0;
scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
scm_c_hook_run (&scm_after_gc_c_hook, 0);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-
-\f
-
-/* The master is global and common while the freelist will be
- * individual for each thread.
- */
-
-SCM
-scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
-{
- SCM cell;
- int did_gc = 0;
-
- scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
- scm_gc_running_p = 1;
-
- *free_cells = scm_i_sweep_for_freelist (freelist);
- if (*free_cells == SCM_EOL)
- {
- float delta = scm_i_gc_heap_size_delta (freelist);
- if (delta > 0.0)
- {
- size_t bytes = ((unsigned long) delta) * sizeof (scm_t_cell);
- freelist->heap_segment_idx =
- scm_i_get_new_heap_segment (freelist, bytes, abort_on_error);
-
- *free_cells = scm_i_sweep_for_freelist (freelist);
- }
- }
-
- if (*free_cells == SCM_EOL)
- {
- /*
- out of fresh cells. Try to get some new ones.
- */
- char reason[] = "0-cells";
- reason[0] += freelist->span;
-
- did_gc = 1;
- scm_i_gc (reason);
-
- *free_cells = scm_i_sweep_for_freelist (freelist);
- }
-
- if (*free_cells == SCM_EOL)
- {
- /*
- failed getting new cells. Get new juice or die.
- */
- float delta = scm_i_gc_heap_size_delta (freelist);
- assert (delta > 0.0);
- size_t bytes = ((unsigned long) delta) * sizeof (scm_t_cell);
- freelist->heap_segment_idx =
- scm_i_get_new_heap_segment (freelist, bytes, abort_on_error);
-
- *free_cells = scm_i_sweep_for_freelist (freelist);
- }
-
- if (*free_cells == SCM_EOL)
- abort ();
-
- cell = *free_cells;
-
- *free_cells = SCM_FREE_CELL_CDR (cell);
-
- scm_gc_running_p = 0;
- scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
-
- if (did_gc)
- scm_c_hook_run (&scm_after_gc_c_hook, 0);
-
- return cell;
-}
-
-
-scm_t_c_hook scm_before_gc_c_hook;
-scm_t_c_hook scm_before_mark_c_hook;
-scm_t_c_hook scm_before_sweep_c_hook;
-scm_t_c_hook scm_after_sweep_c_hook;
-scm_t_c_hook scm_after_gc_c_hook;
-
-static void
-scm_check_deprecated_memory_return ()
-{
- if (scm_mallocated < scm_i_deprecated_memory_return)
- {
- /* The byte count of allocated objects has underflowed. This is
- probably because you forgot to report the sizes of objects you
- have allocated, by calling scm_done_malloc or some such. When
- the GC freed them, it subtracted their size from
- scm_mallocated, which underflowed. */
- fprintf (stderr,
- "scm_gc_sweep: Byte count of allocated objects has underflowed.\n"
- "This is probably because the GC hasn't been correctly informed\n"
- "about object sizes\n");
- abort ();
- }
- scm_mallocated -= scm_i_deprecated_memory_return;
- scm_i_deprecated_memory_return = 0;
-}
-
-long int scm_i_last_marked_cell_count;
-
-/* Must be called while holding scm_i_sweep_mutex.
-
- This function is fairly long, but it touches various global
- variables. To not obscure the side effects on global variables,
- this function has not been split up.
- */
void
scm_i_gc (const char *what)
{
- unsigned long t_before_gc = 0;
-
- scm_i_thread_put_to_sleep ();
-
- scm_c_hook_run (&scm_before_gc_c_hook, 0);
-
-#ifdef DEBUGINFO
- fprintf (stderr,"gc reason %s\n", what);
- fprintf (stderr,
- scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist))
- ? "*"
- : (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2)) ? "o" : "m"));
-#endif
-
- t_before_gc = scm_c_get_internal_run_time ();
- scm_gc_malloc_collected = 0;
-
- /*
- Set freelists to NULL so scm_cons () always triggers gc, causing
- the assertion above to fail.
- */
- *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
- *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
-
- /*
- Let's finish the sweep. The conservative GC might point into the
- garbage, and marking that would create a mess.
- */
- scm_i_sweep_all_segments ("GC", &scm_i_gc_sweep_stats);
- scm_check_deprecated_memory_return ();
-
-#if (SCM_DEBUG_CELL_ACCESSES == 0 && SCM_SIZEOF_UNSIGNED_LONG == 4)
- /* Sanity check our numbers. */
- /* TODO(hanwen): figure out why the stats are off on x64_64. */
- /* If this was not true, someone touched mark bits outside of the
- mark phase. */
- if (scm_i_last_marked_cell_count != scm_i_marked_count ())
- {
- static char msg[] =
- "The number of marked objects changed since the last GC: %d vs %d.";
- /* At some point, we should probably use a deprecation warning. */
- fprintf(stderr, msg, scm_i_last_marked_cell_count, scm_i_marked_count ());
- }
- assert (scm_i_gc_sweep_stats.swept
- == (scm_i_master_freelist.heap_total_cells
- + scm_i_master_freelist2.heap_total_cells));
- assert (scm_i_gc_sweep_stats.collected + scm_i_last_marked_cell_count
- == scm_i_gc_sweep_stats.swept);
-#endif /* SCM_DEBUG_CELL_ACCESSES */
-
- /* Mark */
- scm_c_hook_run (&scm_before_mark_c_hook, 0);
-
- scm_mark_all ();
- scm_gc_mark_time_taken += (scm_c_get_internal_run_time () - t_before_gc);
-
- scm_i_last_marked_cell_count = scm_cells_allocated = scm_i_marked_count ();
-
- /* Sweep
-
- TODO: the after_sweep hook should probably be moved to just before
- the mark, since that's where the sweep is finished in lazy
- sweeping.
-
- MDJ 030219 <djurfeldt@nada.kth.se>: No, probably not. The
- original meaning implied at least two things: that it would be
- called when
-
- 1. the freelist is re-initialized (no evaluation possible, though)
-
- and
-
- 2. the heap is "fresh"
- (it is well-defined what data is used and what is not)
-
- Neither of these conditions would hold just before the mark phase.
-
- Of course, the lazy sweeping has muddled the distinction between
- scm_before_sweep_c_hook and scm_after_sweep_c_hook, but even if
- there were no difference, it would still be useful to have two
- distinct classes of hook functions since this can prevent some
- bad interference when several modules adds gc hooks.
- */
- scm_c_hook_run (&scm_before_sweep_c_hook, 0);
-
- /*
- Nothing here: lazy sweeping.
- */
- scm_i_reset_segments ();
-
- *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
- *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
-
- /* Invalidate the freelists of other threads. */
- scm_i_thread_invalidate_freelists ();
-
- scm_c_hook_run (&scm_after_sweep_c_hook, 0);
-
- gc_end_stats ();
-
- scm_i_gc_sweep_stats.collected = scm_i_gc_sweep_stats.swept = 0;
- scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist);
- scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist2);
-
- /* Arguably, this statistic is fairly useless: marking will dominate
- the time taken.
- */
- scm_gc_time_taken += (scm_c_get_internal_run_time () - t_before_gc);
-
- scm_i_thread_wake_up ();
- /*
- For debugging purposes, you could do
- scm_i_sweep_all_segments ("debug"), but then the remains of the
- cell aren't left to analyse.
- */
+ GC_gcollect ();
}
SCM
scm_permanent_object (SCM obj)
{
- SCM cell = scm_cons (obj, SCM_EOL);
- SCM_CRITICAL_SECTION_START;
- SCM_SETCDR (cell, scm_permobjs);
- scm_permobjs = cell;
- SCM_CRITICAL_SECTION_END;
- return obj;
+ return (scm_gc_protect_object (obj));
}
critsec/mutex inconsistency here. */
SCM_CRITICAL_SECTION_START;
- handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
+ handle = scm_hashq_create_handle_x (protects, obj, scm_from_int (0));
SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
protected_obj_count ++;
abort ();
}
- handle = scm_hashq_get_handle (scm_protects, obj);
+ handle = scm_hashq_get_handle (protects, obj);
if (scm_is_false (handle))
{
{
SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
if (scm_is_eq (count, scm_from_int (0)))
- scm_hashq_remove_x (scm_protects, obj);
+ scm_hashq_remove_x (protects, obj);
else
SCM_SETCDR (handle, count);
}
void
scm_gc_register_root (SCM *p)
{
- SCM handle;
- SCM key = scm_from_ulong ((unsigned long) p);
-
- /* This critical section barrier will be replaced by a mutex. */
- /* njrev: and again. */
- SCM_CRITICAL_SECTION_START;
-
- handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key,
- scm_from_int (0));
- /* njrev: note also that the above can probably signal an error */
- SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
-
- SCM_CRITICAL_SECTION_END;
+ /* Nothing. */
}
void
scm_gc_unregister_root (SCM *p)
{
- SCM handle;
- SCM key = scm_from_ulong ((unsigned long) p);
-
- /* This critical section barrier will be replaced by a mutex. */
- /* njrev: and again. */
- SCM_CRITICAL_SECTION_START;
-
- handle = scm_hashv_get_handle (scm_gc_registered_roots, key);
-
- if (scm_is_false (handle))
- {
- fprintf (stderr, "scm_gc_unregister_root called on unregistered root\n");
- abort ();
- }
- else
- {
- SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
- if (scm_is_eq (count, scm_from_int (0)))
- scm_hashv_remove_x (scm_gc_registered_roots, key);
- else
- SCM_SETCDR (handle, count);
- }
-
- SCM_CRITICAL_SECTION_END;
+ /* Nothing. */
}
void
void
scm_storage_prehistory ()
{
+ GC_all_interior_pointers = 0;
+ GC_set_free_space_divisor (scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3));
+
+ GC_INIT ();
+
+#if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7))) \
+ && (defined SCM_I_GSC_USE_PTHREAD_THREADS)
+ /* When using GC 6.8, this call is required to initialize thread-local
+ freelists (shouldn't be necessary with GC 7.0). */
+ GC_init ();
+#endif
+
+ GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);
+
+ /* We only need to register a displacement for those types for which the
+ higher bits of the type tag are used to store a pointer (that is, a
+ pointer to an 8-octet aligned region). For `scm_tc3_struct', this is
+ handled in `scm_alloc_struct ()'. */
+ GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
+ /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
+
+ /* Sanity check. */
+ if (!GC_is_visible (&protects))
+ abort ();
+
scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-int
-scm_init_storage ()
+void
+scm_init_gc_protect_object ()
{
- size_t j;
-
- j = SCM_NUM_PROTECTS;
- while (j)
- scm_sys_protects[--j] = SCM_BOOL_F;
-
- scm_gc_init_freelist ();
- scm_gc_init_malloc ();
+ protects = scm_c_make_hash_table (31);
#if 0
/* We can't have a cleanup handler since we have no thread to run it
#endif
#endif
-
- scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257));
- scm_permobjs = SCM_EOL;
- scm_protects = scm_c_make_hash_table (31);
- scm_gc_registered_roots = scm_c_make_hash_table (31);
-
- return 0;
}
\f
return NULL;
}
+char const *
+scm_i_tag_name (scm_t_bits tag)
+{
+ if (tag >= 255)
+ {
+ int k = 0xff & (tag >> 8);
+ return (scm_smobs[k].name);
+ }
+
+ switch (tag) /* 7 bits */
+ {
+ case scm_tcs_struct:
+ return "struct";
+ case scm_tcs_cons_imcar:
+ return "cons (immediate car)";
+ case scm_tcs_cons_nimcar:
+ return "cons (non-immediate car)";
+ case scm_tc7_hashtable:
+ return "hashtable";
+ case scm_tc7_fluid:
+ return "fluid";
+ case scm_tc7_dynamic_state:
+ return "dynamic state";
+ case scm_tc7_wvect:
+ return "weak vector";
+ case scm_tc7_vector:
+ return "vector";
+ case scm_tc7_number:
+ switch (tag)
+ {
+ case scm_tc16_real:
+ return "real";
+ break;
+ case scm_tc16_big:
+ return "bignum";
+ break;
+ case scm_tc16_complex:
+ return "complex number";
+ break;
+ case scm_tc16_fraction:
+ return "fraction";
+ break;
+ }
+ break;
+ case scm_tc7_string:
+ return "string";
+ break;
+ case scm_tc7_stringbuf:
+ return "string buffer";
+ break;
+ case scm_tc7_symbol:
+ return "symbol";
+ break;
+ case scm_tc7_variable:
+ return "variable";
+ break;
+ case scm_tc7_gsubr:
+ return "gsubr";
+ break;
+ case scm_tc7_port:
+ return "port";
+ break;
+ case scm_tc7_smob:
+ return "smob"; /* should not occur. */
+ break;
+ }
+
+ return NULL;
+}
+
+
+
+\f
void
scm_init_gc ()
{
- scm_gc_init_mark ();
+ /* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'. */
- scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0));
+ scm_after_gc_hook = scm_make_hook (SCM_INUM0);
scm_c_define ("after-gc-hook", scm_after_gc_hook);
- gc_async = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0,
- gc_async_thunk);
+ gc_async = scm_c_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk);
scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0);
#include "libguile/gc.x"
}
-#ifdef __ia64__
-# ifdef __hpux
-# include <sys/param.h>
-# include <sys/pstat.h>
-void *
-scm_ia64_register_backing_store_base (void)
-{
- struct pst_vm_status vm_status;
- int i = 0;
- while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1)
- if (vm_status.pst_type == PS_RSESTACK)
- return (void *) vm_status.pst_vaddr;
- abort ();
-}
-void *
-scm_ia64_ar_bsp (const void *ctx)
-{
- uint64_t bsp;
- __uc_get_ar_bsp (ctx, &bsp);
- return (void *) bsp;
-}
-# endif /* hpux */
-# ifdef linux
-# include <ucontext.h>
-void *
-scm_ia64_register_backing_store_base (void)
-{
- extern void *__libc_ia64_register_backing_store_base;
- return __libc_ia64_register_backing_store_base;
-}
-void *
-scm_ia64_ar_bsp (const void *opaque)
-{
- const ucontext_t *ctx = opaque;
- return (void *) ctx->uc_mcontext.sc_ar_bsp;
-}
-# endif /* linux */
-#endif /* __ia64__ */
void
scm_gc_sweep (void)
#define FUNC_NAME "scm_gc_sweep"
{
+ /* FIXME */
+ fprintf (stderr, "%s: doing nothing\n", __FUNCTION__);
}
#undef FUNC_NAME
#ifndef SCM_GC_H
#define SCM_GC_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 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
#include "libguile/threads.h"
\f
-
-/* Cell allocation and garbage collection work rouhgly in the
- following manner:
-
- Each thread has a 'freelist', which is a list of available cells.
- (It actually has two freelists, one for single cells and one for
- double cells. Everything works analogous for double cells.)
-
- When a thread wants to allocate a cell and the freelist is empty,
- it refers to a global list of unswept 'cards'. A card is a small
- block of cells that are contigous in memory, together with the
- corresponding mark bits. A unswept card is one where the mark bits
- are set for cells that have been in use during the last global mark
- phase, but the unmarked cells of the card have not been scanned and
- freed yet.
-
- The thread takes one of the unswept cards and sweeps it, thereby
- building a new freelist that it then uses. Sweeping a card will
- call the smob free functions of unmarked cells, for example, and
- thus, these free functions can run at any time, in any thread.
-
- When there are no more unswept cards available, the thread performs
- a global garbage collection. For this, all other threads are
- stopped. A global mark is performed and all cards are put into the
- global list of unswept cards. Whennecessary, new cards are
- allocated and initialized at this time. The other threads are then
- started again.
-*/
-
typedef struct scm_t_cell
{
SCM word_0;
SCM word_1;
} scm_t_cell;
-/*
- CARDS
-
- A card is a small `page' of memory; it will be the unit for lazy
- sweeping, generations, etc. The first cell of a card contains a
- pointer to the mark bitvector, so that we can find the bitvector
- efficiently: we knock off some lowerorder bits.
-
- The size on a 32 bit machine is 256 cells = 2kb. The card [XXX]
-*/
-
-
-
/* Cray machines have pointers that are incremented once for each
* word, rather than each byte, the 3 most significant bits encode the
* byte within the word. The following macros deal with this by
#endif /* def _UNICOS */
-#define SCM_GC_CARD_N_HEADER_CELLS 1
-#define SCM_GC_CARD_N_CELLS 256
-#define SCM_GC_SIZEOF_CARD SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell)
-
-#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_long *) ((card)->word_0))
-#define SCM_GC_SET_CARD_BVEC(card, bvec) \
- ((card)->word_0 = (SCM) (bvec))
-#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1))
-#define SCM_GC_SET_CARD_FLAGS(card, flags) \
- ((card)->word_1 = (SCM) (flags))
-
-#define SCM_GC_GET_CARD_FLAG(card, shift) \
- (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift)))
-#define SCM_GC_SET_CARD_FLAG(card, shift) \
- (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) | (1L << (shift))))
-#define SCM_GC_CLEAR_CARD_FLAG(card, shift) \
- (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) & ~(1L << (shift))))
-
-/*
- Remove card flags. They hamper lazy initialization, and aren't used
- anyways.
- */
-
-/* card addressing. for efficiency, cards are *always* aligned to
- SCM_GC_CARD_SIZE. */
-
-#define SCM_GC_CARD_SIZE_MASK (SCM_GC_SIZEOF_CARD-1)
-#define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK)
-
-#define SCM_GC_CELL_CARD(x) ((scm_t_cell *) ((long) (x) & SCM_GC_CARD_ADDR_MASK))
-#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT)
-#define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x))
-#define SCM_GC_SET_CELL_BVEC(x, bvec) SCM_GC_SET_CARD_BVEC (SCM_GC_CELL_CARD (x), bvec)
-#define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
-#define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
-#define SCM_GC_CELL_CLEAR_BIT(x) SCM_C_BVEC_CLEAR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
-
-#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_SIZEOF_CARD - 1)
-#define SCM_GC_CARD_DOWN SCM_GC_CELL_CARD
-
-/* low level bit banging aids */
-typedef unsigned long scm_t_c_bvec_long;
-
-#if (SCM_SIZEOF_UNSIGNED_LONG == 8)
-# define SCM_C_BVEC_LONG_BITS 64
-# define SCM_C_BVEC_OFFSET_SHIFT 6
-# define SCM_C_BVEC_POS_MASK 63
-# define SCM_CELL_SIZE_SHIFT 4
-#else
-# define SCM_C_BVEC_LONG_BITS 32
-# define SCM_C_BVEC_OFFSET_SHIFT 5
-# define SCM_C_BVEC_POS_MASK 31
-# define SCM_CELL_SIZE_SHIFT 3
-#endif
-
-#define SCM_C_BVEC_OFFSET(pos) (pos >> SCM_C_BVEC_OFFSET_SHIFT)
-
-#define SCM_C_BVEC_GET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] & (1L << (pos & SCM_C_BVEC_POS_MASK)))
-#define SCM_C_BVEC_SET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] |= (1L << (pos & SCM_C_BVEC_POS_MASK)))
-#define SCM_C_BVEC_CLEAR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK)))
-
-/* testing and changing GC marks */
-#define SCM_GC_MARK_P(x) SCM_GC_CELL_GET_BIT (x)
-
-SCM_INTERNAL void scm_i_ensure_marking(void);
-
-#if (SCM_DEBUG_MARKING_API == 1)
-#define SCM_I_ENSURE_MARKING scm_i_ensure_marking(),
-#else
-#define SCM_I_ENSURE_MARKING
-#endif
-
-#define SCM_SET_GC_MARK(x) SCM_I_ENSURE_MARKING SCM_GC_CELL_SET_BIT (x)
-#define SCM_CLEAR_GC_MARK(x) SCM_I_ENSURE_MARKING SCM_GC_CELL_CLEAR_BIT (x)
/* Low level cell data accessing macros. These macros should only be used
* from within code related to garbage collection issues, since they will
#define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x)
#define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 ((x), (t))
-/* Freelists consist of linked cells where the type entry holds the value
- * scm_tc_free_cell and the second entry holds a pointer to the next cell of
- * the freelist. Due to this structure, freelist cells are not cons cells
- * and thus may not be accessed using SCM_CAR and SCM_CDR. */
-
-#define SCM_FREE_CELL_CDR(x) \
- (SCM_GC_CELL_OBJECT ((x), 1))
-#define SCM_SET_FREE_CELL_CDR(x, v) \
- (SCM_GC_SET_CELL_OBJECT ((x), 1, (v)))
#if (SCM_DEBUG_CELL_ACCESSES == 1)
/* Set this to != 0 if every cell that is accessed shall be checked:
SCM_API int scm_debug_cell_accesses_p;
SCM_API int scm_expensive_debug_cell_accesses_p;
SCM_API int scm_debug_cells_gc_interval ;
-void scm_i_expensive_validation_check (SCM cell);
+SCM_API void scm_i_expensive_validation_check (SCM cell);
#endif
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_gc_admin_mutex;
-#define scm_gc_running_p (SCM_I_CURRENT_THREAD->gc_running_p)
+#define scm_gc_running_p 0
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_sweep_mutex;
#ifdef __ia64__
\f
#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_API size_t scm_default_init_heap_size_1;
-SCM_API int scm_default_min_yield_1;
-SCM_API size_t scm_default_init_heap_size_2;
-SCM_API int scm_default_min_yield_2;
-SCM_API size_t scm_default_max_segment_size;
+SCM_DEPRECATED size_t scm_default_init_heap_size_1;
+SCM_DEPRECATED int scm_default_min_yield_1;
+SCM_DEPRECATED size_t scm_default_init_heap_size_2;
+SCM_DEPRECATED int scm_default_min_yield_2;
+SCM_DEPRECATED size_t scm_default_max_segment_size;
#else
#define scm_default_init_heap_size_1 deprecated
#define scm_default_min_yield_1 deprecated
#define scm_default_max_segment_size deprecated
#endif
-
-SCM_API size_t scm_max_segment_size;
-
-#define SCM_SET_FREELIST_LOC(key,ptr) scm_i_pthread_setspecific ((key), (ptr))
-#define SCM_FREELIST_LOC(key) ((SCM *) scm_i_pthread_getspecific (key))
-SCM_API scm_i_pthread_key_t scm_i_freelist;
-SCM_API scm_i_pthread_key_t scm_i_freelist2;
-SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
-SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
-
-SCM_API unsigned long scm_gc_malloc_collected;
-SCM_API int scm_gc_malloc_yield_percentage;
-SCM_API unsigned long scm_mallocated;
-SCM_API unsigned long scm_mtrigger;
+SCM_API unsigned long scm_gc_ports_collected;
SCM_API SCM scm_after_gc_hook;
SCM_API scm_t_c_hook scm_after_sweep_c_hook;
SCM_API scm_t_c_hook scm_after_gc_c_hook;
-#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
-#if (SCM_ENABLE_DEPRECATED == 1)
-SCM scm_map_free_list (void);
-#else
-#define scm_map_free_list deprecated
-#define scm_free_list_length deprecated
-#endif
-#endif
-
-#if (SCM_ENABLE_DEPRECATED == 1) && defined (GUILE_DEBUG_FREELIST)
-SCM_API SCM scm_gc_set_debug_check_freelist_x (SCM flag);
-#endif
\f
#if (SCM_DEBUG_CELL_ACCESSES == 1)
SCM_API SCM scm_object_address (SCM obj);
+SCM_API SCM scm_gc_enable (void);
+SCM_API SCM scm_gc_disable (void);
+SCM_API SCM scm_gc_dump (void);
SCM_API SCM scm_gc_stats (void);
SCM_API SCM scm_gc_live_object_stats (void);
SCM_API SCM scm_gc (void);
-SCM_API void scm_gc_for_alloc (struct scm_t_cell_type_statistics *freelist);
-SCM_API SCM scm_gc_for_newcell (struct scm_t_cell_type_statistics *master, SCM *freelist);
-SCM_INTERNAL void scm_i_gc (const char *what);
+SCM_API void scm_i_gc (const char *what);
SCM_API void scm_gc_mark (SCM p);
-SCM_API void scm_gc_mark_dependencies (SCM p);
-SCM_API void scm_mark_locations (SCM_STACKITEM x[], unsigned long n);
-SCM_API int scm_in_heap_p (SCM value);
SCM_API void scm_gc_sweep (void);
SCM_API void *scm_malloc (size_t size);
const char *what);
SCM_API void scm_gc_unregister_collectable_memory (void *mem, size_t size,
const char *what);
+SCM_API void *scm_gc_malloc_pointerless (size_t size, const char *what);
SCM_API void *scm_gc_calloc (size_t size, const char *what);
SCM_API void *scm_gc_malloc (size_t size, const char *what);
SCM_API void *scm_gc_realloc (void *mem, size_t old_size,
SCM_API void scm_gc_unregister_root (SCM *p);
SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
-SCM_API void scm_storage_prehistory (void);
-SCM_API int scm_init_storage (void);
-SCM_API void *scm_get_stack_base (void);
+SCM_INTERNAL void scm_storage_prehistory (void);
+SCM_INTERNAL void scm_init_gc_protect_object (void);
SCM_INTERNAL void scm_init_gc (void);
#if SCM_ENABLE_DEPRECATED == 1
-SCM_API SCM scm_deprecated_newcell (void);
-SCM_API SCM scm_deprecated_newcell2 (void);
+SCM_DEPRECATED SCM scm_deprecated_newcell (void);
+SCM_DEPRECATED SCM scm_deprecated_newcell2 (void);
#define SCM_NEWCELL(_into) \
do { _into = scm_deprecated_newcell (); } while (0)
#define SCM_NEWCELL2(_into) \
do { _into = scm_deprecated_newcell2 (); } while (0)
-SCM_API void * scm_must_malloc (size_t len, const char *what);
-SCM_API void * scm_must_realloc (void *where,
- size_t olen, size_t len,
- const char *what);
-SCM_API char *scm_must_strdup (const char *str);
-SCM_API char *scm_must_strndup (const char *str, size_t n);
-SCM_API void scm_done_malloc (long size);
-SCM_API void scm_done_free (long size);
-SCM_API void scm_must_free (void *obj);
+SCM_DEPRECATED void * scm_must_malloc (size_t len, const char *what);
+SCM_DEPRECATED void * scm_must_realloc (void *where,
+ size_t olen, size_t len,
+ const char *what);
+SCM_DEPRECATED char *scm_must_strdup (const char *str);
+SCM_DEPRECATED char *scm_must_strndup (const char *str, size_t n);
+SCM_DEPRECATED void scm_done_malloc (long size);
+SCM_DEPRECATED void scm_done_free (long size);
+SCM_DEPRECATED void scm_must_free (void *obj);
#endif
+++ /dev/null
-/*
- * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers
- * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved.
- * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved.
- * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved.
- * Copyright (c) 2000, 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation
- *
- * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
- * OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
- *
- * Permission is hereby granted to use or copy this program
- * for any purpose, provided the above notices are retained on all copies.
- * Permission to modify the code and to distribute modified code is granted,
- * provided the above notices are retained, and a notice that the code was
- * modified is included with the above copyright notice.
- *
- */
-
-/*
- * Copied from gc5.2, files "os_dep.c", "gc_priv.h", "mark.c" and "gcconfig.h",
- * and modified for Guile by Marius Vollmer.
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <ctype.h>
-#include "libguile/gc.h"
-#include "libguile/scmconfig.h"
-
-#ifdef HAVE_LIBC_STACK_END
-
-extern void *__libc_stack_end;
-
-void *
-scm_get_stack_base ()
-{
- return __libc_stack_end;
-}
-
-#else
-
-#define ABORT(msg) abort ()
-
-typedef char * ptr_t; /* A generic pointer to which we can add */
- /* byte displacements. */
- /* Preferably identical to caddr_t, if it */
- /* exists. */
-
-/* Define word and signed_word to be unsigned and signed types of the */
-/* size as char * or void *. There seems to be no way to do this */
-/* even semi-portably. The following is probably no better/worse */
-/* than almost anything else. */
-/* The ANSI standard suggests that size_t and ptr_diff_t might be */
-/* better choices. But those appear to have incorrect definitions */
-/* on may systems. Notably "typedef int size_t" seems to be both */
-/* frequent and WRONG. */
-typedef unsigned long GC_word;
-typedef long GC_signed_word;
-
-typedef GC_word word;
-typedef GC_signed_word signed_word;
-
-typedef int GC_bool;
-# define TRUE 1
-# define FALSE 0
-
-#if defined(__STDC__)
-# include <stdlib.h>
-# if !(defined( sony_news ) )
-# include <stddef.h>
-# endif
-# define VOLATILE volatile
-#else
-# ifdef MSWIN32
-# include <stdlib.h>
-# endif
-# define VOLATILE
-#endif
-
-/* Machine dependent parameters. Some tuning parameters can be found */
-/* near the top of gc_private.h. */
-
-/* Machine specific parts contributed by various people. See README file. */
-
-/* First a unified test for Linux: */
-# if defined(linux) || defined(__linux__)
-# define LINUX
-# endif
-
-/* Determine the machine type: */
-# if defined(sun) && defined(mc68000)
-# define M68K
-# define SUNOS4
-# define mach_type_known
-# endif
-# if defined(hp9000s300)
-# define M68K
-# define HP
-# define mach_type_known
-# endif
-# if defined(__OpenBSD__) && defined(m68k)
-# define M68K
-# define OPENBSD
-# define mach_type_known
-# endif
-# if defined(__OpenBSD__) && defined(__sparc__)
-# define SPARC
-# define OPENBSD
-# define mach_type_known
-# endif
-# if defined(__NetBSD__) && defined(__alpha__)
-# define ALPHA
-# define NETBSD
-# define mach_type_known
-# endif
-# if defined(__NetBSD__) && defined(__powerpc__)
-# define POWERPC
-# define NETBSD
-# define mach_type_known
-# endif
-/* in netbsd 2.0 only __m68k__ is defined, not m68k */
-# if defined(__NetBSD__) && (defined(m68k) || defined(__m68k__))
-# define M68K
-# define NETBSD
-# define mach_type_known
-# endif
-/* in netbsd 2.0 only __arm__ is defined, not arm32 */
-# if defined(__NetBSD__) && (defined(arm32) || defined(__arm__))
-# define ARM32
-# define NETBSD
-# define mach_type_known
-# endif
-# if defined(__NetBSD__) && defined(__sparc__)
-# define SPARC
-# define NETBSD
-# define mach_type_known
-# endif
-# if defined(vax)
-# define VAX
-# ifdef ultrix
-# define ULTRIX
-# else
-# define BSD
-# endif
-# define mach_type_known
-# endif
-# if defined(mips) || defined(__mips)
-# define MIPS
-# if !defined(LINUX)
-# if defined(ultrix) || defined(__ultrix) || defined(__NetBSD__)
-# define ULTRIX
-# else
-# if defined(_SYSTYPE_SVR4) || defined(SYSTYPE_SVR4) \
- || defined(__SYSTYPE_SVR4__)
-# define IRIX5 /* or IRIX 6.X */
-# else
-# define RISCOS /* or IRIX 4.X */
-# endif
-# endif
-# endif /* !LINUX */
-# define mach_type_known
-# endif
-# if defined(sequent) && defined(i386)
-# define I386
-# define SEQUENT
-# define mach_type_known
-# endif
-# if defined(sun) && defined(i386)
-# define I386
-# define SUNOS5
-# define mach_type_known
-# endif
-# if (defined(__OS2__) || defined(__EMX__)) && defined(__32BIT__)
-# define I386
-# define OS2
-# define mach_type_known
-# endif
-# if defined(ibm032)
-# define RT
-# define mach_type_known
-# endif
-# if defined(sun) && (defined(sparc) || defined(__sparc))
-# define SPARC
- /* Test for SunOS 5.x */
-# include <errno.h>
-# ifdef ECHRNG
-# define SUNOS5
-# else
-# define SUNOS4
-# endif
-# define mach_type_known
-# endif
-# if defined(sparc) && defined(unix) && !defined(sun) && !defined(linux) \
- && !defined(__OpenBSD__)
-# define SPARC
-# define DRSNX
-# define mach_type_known
-# endif
-# if defined(_IBMR2)
-# define RS6000
-# define mach_type_known
-# endif
-# if defined(_M_XENIX) && defined(_M_SYSV) && defined(_M_I386)
- /* The above test may need refinement */
-# define I386
-# if defined(_SCO_ELF)
-# define SCO_ELF
-# else
-# define SCO
-# endif
-# define mach_type_known
-# endif
-# if defined(_AUX_SOURCE)
-# define M68K
-# define SYSV
-# define mach_type_known
-# endif
-# if defined(_PA_RISC1_0) || defined(_PA_RISC1_1) || defined(_PA_RISC2_0) \
- || defined(hppa) || defined(__hppa__)
-# define HP_PA
-# ifndef LINUX
-# define HPUX
-# endif
-# define mach_type_known
-# endif
-# if defined(LINUX) && (defined(i386) || defined(__i386__))
-# define I386
-# define mach_type_known
-# endif
-# if defined(LINUX) && (defined(__ia64__) || defined(__ia64))
-# define IA64
-# define mach_type_known
-# endif
-# if defined(LINUX) && defined(powerpc)
-# define POWERPC
-# define mach_type_known
-# endif
-# if defined(LINUX) && defined(__mc68000__)
-# define M68K
-# define mach_type_known
-# endif
-# if defined(LINUX) && (defined(sparc) || defined(__sparc__))
-# define SPARC
-# define mach_type_known
-# endif
-# if defined(LINUX) && (defined(arm) || defined (__arm__))
-# define ARM32
-# define mach_type_known
-# endif
-# if defined(__alpha) || defined(__alpha__)
-# define ALPHA
-# if !defined(LINUX) && !defined (NETBSD)
-# define OSF1 /* a.k.a Digital Unix */
-# endif
-# define mach_type_known
-# endif
-# if defined(_AMIGA) && !defined(AMIGA)
-# define AMIGA
-# endif
-# ifdef AMIGA
-# define M68K
-# define mach_type_known
-# endif
-# if defined(THINK_C) || defined(__MWERKS__) && !defined(__powerc)
-# define M68K
-# define MACOS
-# define mach_type_known
-# endif
-# if defined(__MWERKS__) && defined(__powerc)
-# define POWERPC
-# define MACOS
-# define mach_type_known
-# endif
-# if defined(macosx) || \
- (defined(__APPLE__) && defined(__MACH__) && defined(__ppc__))
-# define MACOSX
-# define POWERPC
-# define mach_type_known
-# endif
-# if defined(NeXT) && defined(mc68000)
-# define M68K
-# define NEXT
-# define mach_type_known
-# endif
-# if defined(NeXT) && defined(i386)
-# define I386
-# define NEXT
-# define mach_type_known
-# endif
-# if defined(__OpenBSD__) && (defined(i386) || defined(__i386__))
-# define I386
-# define OPENBSD
-# define mach_type_known
-# endif
-# if defined(__FreeBSD__) && defined(i386)
-# define I386
-# define FREEBSD
-# define mach_type_known
-# endif
-# if defined(__NetBSD__) && defined(i386)
-# define I386
-# define NETBSD
-# define mach_type_known
-# endif
-# if defined(bsdi) && defined(i386)
-# define I386
-# define BSDI
-# define mach_type_known
-# endif
-# if !defined(mach_type_known) && defined(__386BSD__)
-# define I386
-# define THREE86BSD
-# define mach_type_known
-# endif
-# if defined(_CX_UX) && defined(_M88K)
-# define M88K
-# define CX_UX
-# define mach_type_known
-# endif
-# if defined(DGUX)
-# define M88K
- /* DGUX defined */
-# define mach_type_known
-# endif
-# if (defined(_MSDOS) || defined(_MSC_VER)) && (_M_IX86 >= 300) \
- || defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__CYGWIN__)
-# define I386
-# define MSWIN32 /* or Win32s */
-# define mach_type_known
-# endif
-# if defined(__DJGPP__)
-# define I386
-# ifndef DJGPP
-# define DJGPP /* MSDOS running the DJGPP port of GCC */
-# endif
-# define mach_type_known
-# endif
-# if defined(__CYGWIN32__) || defined(__CYGWIN__)
-# define I386
-# define CYGWIN32
-# define mach_type_known
-# endif
-# if defined(__MINGW32__)
-# define I386
-# define MSWIN32
-# define mach_type_known
-# endif
-# if defined(__BORLANDC__)
-# define I386
-# define MSWIN32
-# define mach_type_known
-# endif
-# if defined(_UTS) && !defined(mach_type_known)
-# define S370
-# define UTS4
-# define mach_type_known
-# endif
-# if defined(__pj__)
-# define PJ
-# define mach_type_known
-# endif
-/* Ivan Demakov */
-# if defined(__WATCOMC__) && defined(__386__)
-# define I386
-# if !defined(OS2) && !defined(MSWIN32) && !defined(DOS4GW)
-# if defined(__OS2__)
-# define OS2
-# else
-# if defined(__WINDOWS_386__) || defined(__NT__)
-# define MSWIN32
-# else
-# define DOS4GW
-# endif
-# endif
-# endif
-# define mach_type_known
-# endif
-# if defined(__s390__) && defined(LINUX)
-# define S370
-# define mach_type_known
-# endif
-# if defined(__GNU__)
-# define I386
-# define GNU
-# define mach_type_known
-# endif
-# if defined(__SCO_VERSION__)
-# define I386
-# define SYSV
-# define mach_type_known
-# endif
-
-/* Feel free to add more clauses here */
-
-/* Or manually define the machine type here. A machine type is */
-/* characterized by the architecture. Some */
-/* machine types are further subdivided by OS. */
-/* the macros ULTRIX, RISCOS, and BSD to distinguish. */
-/* Note that SGI IRIX is treated identically to RISCOS. */
-/* SYSV on an M68K actually means A/UX. */
-/* The distinction in these cases is usually the stack starting address */
-# ifndef mach_type_known
-
-void *
-scm_get_stack_base ()
-{
- ABORT ("Can't determine stack base");
- return NULL;
-}
-
-# else
- /* Mapping is: M68K ==> Motorola 680X0 */
- /* (SUNOS4,HP,NEXT, and SYSV (A/UX), */
- /* MACOS and AMIGA variants) */
- /* I386 ==> Intel 386 */
- /* (SEQUENT, OS2, SCO, LINUX, NETBSD, */
- /* FREEBSD, THREE86BSD, MSWIN32, */
- /* BSDI,SUNOS5, NEXT, other variants) */
- /* NS32K ==> Encore Multimax */
- /* MIPS ==> R2000 or R3000 */
- /* (RISCOS, ULTRIX variants) */
- /* VAX ==> DEC VAX */
- /* (BSD, ULTRIX variants) */
- /* RS6000 ==> IBM RS/6000 AIX3.X */
- /* RT ==> IBM PC/RT */
- /* HP_PA ==> HP9000/700 & /800 */
- /* HP/UX */
- /* SPARC ==> SPARC under SunOS */
- /* (SUNOS4, SUNOS5, */
- /* DRSNX variants) */
- /* ALPHA ==> DEC Alpha */
- /* (OSF1 and LINUX variants) */
- /* M88K ==> Motorola 88XX0 */
- /* (CX_UX and DGUX) */
- /* S370 ==> 370-like machine */
- /* running Amdahl UTS4 */
- /* ARM32 ==> Intel StrongARM */
- /* IA64 ==> Intel IA64 */
- /* (e.g. Itanium) */
-
-
-/*
- * For each architecture and OS, the following need to be defined:
- *
- * CPP_WORD_SZ is a simple integer constant representing the word size.
- * in bits. We assume byte addressibility, where a byte has 8 bits.
- * We also assume CPP_WORD_SZ is either 32 or 64.
- * (We care about the length of pointers, not hardware
- * bus widths. Thus a 64 bit processor with a C compiler that uses
- * 32 bit pointers should use CPP_WORD_SZ of 32, not 64. Default is 32.)
- *
- * MACH_TYPE is a string representation of the machine type.
- * OS_TYPE is analogous for the OS.
- *
- * ALIGNMENT is the largest N, such that
- * all pointer are guaranteed to be aligned on N byte boundaries.
- * defining it to be 1 will always work, but perform poorly.
- *
- * DATASTART is the beginning of the data segment.
- * On UNIX systems, the collector will scan the area between DATASTART
- * and DATAEND for root pointers.
- *
- * DATAEND, if not &end.
- *
- * ALIGN_DOUBLE of GC_malloc should return blocks aligned to twice
- * the pointer size.
- *
- * STACKBOTTOM is the cool end of the stack, which is usually the
- * highest address in the stack.
- * Under PCR or OS/2, we have other ways of finding thread stacks.
- * For each machine, the following should:
- * 1) define SCM_STACK_GROWS_UP if the stack grows toward higher addresses, and
- * 2) define exactly one of
- * STACKBOTTOM (should be defined to be an expression)
- * HEURISTIC1
- * HEURISTIC2
- * If either of the last two macros are defined, then STACKBOTTOM is computed
- * during collector startup using one of the following two heuristics:
- * HEURISTIC1: Take an address inside GC_init's frame, and round it up to
- * the next multiple of STACK_GRAN.
- * HEURISTIC2: Take an address inside GC_init's frame, increment it repeatedly
- * in small steps (decrement if SCM_STACK_GROWS_UP), and read the value
- * at each location. Remember the value when the first
- * Segmentation violation or Bus error is signalled. Round that
- * to the nearest plausible page boundary, and use that instead
- * of STACKBOTTOM.
- *
- * Gustavo Rodriguez-Rivera points out that on most (all?) Unix machines,
- * the value of environ is a pointer that can serve as STACKBOTTOM.
- * I expect that HEURISTIC2 can be replaced by this approach, which
- * interferes far less with debugging.
- *
- * If no expression for STACKBOTTOM can be found, and neither of the above
- * heuristics are usable, the collector can still be used with all of the above
- * undefined, provided one of the following is done:
- * 1) GC_mark_roots can be changed to somehow mark from the correct stack(s)
- * without reference to STACKBOTTOM. This is appropriate for use in
- * conjunction with thread packages, since there will be multiple stacks.
- * (Allocating thread stacks in the heap, and treating them as ordinary
- * heap data objects is also possible as a last resort. However, this is
- * likely to introduce significant amounts of excess storage retention
- * unless the dead parts of the thread stacks are periodically cleared.)
- * 2) Client code may set GC_stackbottom before calling any GC_ routines.
- * If the author of the client code controls the main program, this is
- * easily accomplished by introducing a new main program, setting
- * GC_stackbottom to the address of a local variable, and then calling
- * the original main program. The new main program would read something
- * like:
- *
- * # include "gc_private.h"
- *
- * main(argc, argv, envp)
- * int argc;
- * char **argv, **envp;
- * {
- * int dummy;
- *
- * GC_stackbottom = (ptr_t)(&dummy);
- * return(real_main(argc, argv, envp));
- * }
- *
- *
- * Each architecture may also define the style of virtual dirty bit
- * implementation to be used:
- * MPROTECT_VDB: Write protect the heap and catch faults.
- * PROC_VDB: Use the SVR4 /proc primitives to read dirty bits.
- *
- * An architecture may define DYNAMIC_LOADING if dynamic_load.c
- * defined GC_register_dynamic_libraries() for the architecture.
- *
- * An architecture may define PREFETCH(x) to preload the cache with *x.
- * This defaults to a no-op.
- *
- * PREFETCH_FOR_WRITE(x) is used if *x is about to be written.
- *
- * An architecture may also define CLEAR_DOUBLE(x) to be a fast way to
- * clear the two words at GC_malloc-aligned address x. By default,
- * word stores of 0 are used instead.
- */
-
-
-# define STACK_GRAN 0x1000000
-# ifdef M68K
-# define MACH_TYPE "M68K"
-# define ALIGNMENT 2
-# ifdef OPENBSD
-# define OS_TYPE "OPENBSD"
-# define HEURISTIC2
- extern char etext;
-# define DATASTART ((ptr_t)(&etext))
-# endif
-# ifdef NETBSD
-# define OS_TYPE "NETBSD"
-# define HEURISTIC2
- extern char etext;
-# define DATASTART ((ptr_t)(&etext))
-# endif
-# ifdef LINUX
-# define OS_TYPE "LINUX"
-# define STACKBOTTOM ((ptr_t)0xf0000000)
-# define MPROTECT_VDB
-# ifdef __ELF__
-# define DYNAMIC_LOADING
- extern char **__environ;
-# define DATASTART ((ptr_t)(&__environ))
- /* hideous kludge: __environ is the first */
- /* word in crt0.o, and delimits the start */
- /* of the data segment, no matter which */
- /* ld options were passed through. */
- /* We could use _etext instead, but that */
- /* would include .rodata, which may */
- /* contain large read-only data tables */
- /* that we'd rather not scan. */
- extern int _end;
-# define DATAEND (&_end)
-# else
- extern int etext;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
-# endif
-# endif
-# ifdef SUNOS4
-# define OS_TYPE "SUNOS4"
- extern char etext;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0x1ffff) & ~0x1ffff))
-# define HEURISTIC1 /* differs */
-# define DYNAMIC_LOADING
-# endif
-# ifdef HP
-# define OS_TYPE "HP"
- extern char etext;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
-# define STACKBOTTOM ((ptr_t) 0xffeffffc)
- /* empirically determined. seems to work. */
-# include <unistd.h>
-# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE)
-# endif
-# ifdef SYSV
-# define OS_TYPE "SYSV"
- extern etext;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0x3fffff) \
- & ~0x3fffff) \
- +((word)&etext & 0x1fff))
- /* This only works for shared-text binaries with magic number 0413.
- The other sorts of SysV binaries put the data at the end of the text,
- in which case the default of &etext would work. Unfortunately,
- handling both would require having the magic-number available.
- -- Parag
- */
-# define STACKBOTTOM ((ptr_t)0xFFFFFFFE)
- /* The stack starts at the top of memory, but */
- /* 0x0 cannot be used as setjump_test complains */
- /* that the stack direction is incorrect. Two */
- /* bytes down from 0x0 should be safe enough. */
- /* --Parag */
-# include <sys/mmu.h>
-# define GETPAGESIZE() PAGESIZE /* Is this still right? */
-# endif
-# ifdef AMIGA
-# define OS_TYPE "AMIGA"
- /* STACKBOTTOM and DATASTART handled specially */
- /* in os_dep.c */
-# define DATAEND /* not needed */
-# define GETPAGESIZE() 4096
-# endif
-# ifdef MACOS
-# ifndef __LOWMEM__
-# include <LowMem.h>
-# endif
-# define OS_TYPE "MACOS"
- /* see os_dep.c for details of global data segments. */
-# define STACKBOTTOM ((ptr_t) LMGetCurStackBase())
-# define DATAEND /* not needed */
-# define GETPAGESIZE() 4096
-# endif
-# ifdef NEXT
-# define OS_TYPE "NEXT"
-# define DATASTART ((ptr_t) get_etext())
-# define STACKBOTTOM ((ptr_t) 0x4000000)
-# define DATAEND /* not needed */
-# endif
-# endif
-
-# ifdef POWERPC
-# define MACH_TYPE "POWERPC"
-# ifdef MACOS
-# define ALIGNMENT 2 /* Still necessary? Could it be 4? */
-# ifndef __LOWMEM__
-# include <LowMem.h>
-# endif
-# define OS_TYPE "MACOS"
- /* see os_dep.c for details of global data segments. */
-# define STACKBOTTOM ((ptr_t) LMGetCurStackBase())
-# define DATAEND /* not needed */
-# endif
-# ifdef LINUX
-# define ALIGNMENT 4 /* Guess. Can someone verify? */
- /* This was 2, but that didn't sound right. */
-# define OS_TYPE "LINUX"
-# define HEURISTIC1
-# define DYNAMIC_LOADING
-# undef STACK_GRAN
-# define STACK_GRAN 0x10000000
- /* Stack usually starts at 0x80000000 */
-# define LINUX_DATA_START
- extern int _end;
-# define DATAEND (&_end)
-# endif
-# ifdef MACOSX
-# define ALIGNMENT 4
-# define OS_TYPE "MACOSX"
-# define DATASTART ((ptr_t) get_etext())
-# define STACKBOTTOM ((ptr_t) 0xc0000000)
-# define DATAEND /* not needed */
-# endif
-# endif
-
-# ifdef VAX
-# define MACH_TYPE "VAX"
-# define ALIGNMENT 4 /* Pointers are longword aligned by 4.2 C compiler */
- extern char etext;
-# define DATASTART ((ptr_t)(&etext))
-# ifdef BSD
-# define OS_TYPE "BSD"
-# define HEURISTIC1
- /* HEURISTIC2 may be OK, but it's hard to test. */
-# endif
-# ifdef ULTRIX
-# define OS_TYPE "ULTRIX"
-# define STACKBOTTOM ((ptr_t) 0x7fffc800)
-# endif
-# endif
-
-# ifdef RT
-# define MACH_TYPE "RT"
-# define ALIGNMENT 4
-# define DATASTART ((ptr_t) 0x10000000)
-# define STACKBOTTOM ((ptr_t) 0x1fffd800)
-# endif
-
-# ifdef SPARC
-# define MACH_TYPE "SPARC"
-# define ALIGNMENT 4 /* Required by hardware */
-# define ALIGN_DOUBLE
- extern int etext;
-# ifdef SUNOS5
-# define OS_TYPE "SUNOS5"
- extern int _etext;
- extern int _end;
- extern char * GC_SysVGetDataStart();
-# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &_etext)
-# define DATAEND (&_end)
-# ifndef USE_MMAP
-# define USE_MMAP
-# endif
-# ifdef USE_MMAP
-# define HEAP_START (ptr_t)0x40000000
-# else
-# define HEAP_START DATAEND
-# endif
-# define PROC_VDB
-/* HEURISTIC1 reportedly no longer works under 2.7. Thus we */
-/* switched to HEURISTIC2, eventhough it creates some debugging */
-/* issues. */
-# define HEURISTIC2
-# include <unistd.h>
-# define GETPAGESIZE() sysconf(_SC_PAGESIZE)
- /* getpagesize() appeared to be missing from at least one */
- /* Solaris 5.4 installation. Weird. */
-# define DYNAMIC_LOADING
-# endif
-# ifdef SUNOS4
-# define OS_TYPE "SUNOS4"
- /* [If you have a weak stomach, don't read this.] */
- /* We would like to use: */
-/* # define DATASTART ((ptr_t)((((word) (&etext)) + 0x1fff) & ~0x1fff)) */
- /* This fails occasionally, due to an ancient, but very */
- /* persistent ld bug. &etext is set 32 bytes too high. */
- /* We instead read the text segment size from the a.out */
- /* header, which happens to be mapped into our address space */
- /* at the start of the text segment. The detective work here */
- /* was done by Robert Ehrlich, Manuel Serrano, and Bernard */
- /* Serpette of INRIA. */
- /* This assumes ZMAGIC, i.e. demand-loadable executables. */
-# define TEXTSTART 0x2000
-# define DATASTART ((ptr_t)(*(int *)(TEXTSTART+0x4)+TEXTSTART))
-# define MPROTECT_VDB
-# define HEURISTIC1
-# define DYNAMIC_LOADING
-# endif
-# ifdef DRSNX
-# define CPP_WORDSZ 32
-# define OS_TYPE "DRSNX"
- extern char * GC_SysVGetDataStart();
- extern int etext;
-# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &etext)
-# define MPROTECT_VDB
-# define STACKBOTTOM ((ptr_t) 0xdfff0000)
-# define DYNAMIC_LOADING
-# endif
-# ifdef LINUX
-# define OS_TYPE "LINUX"
-# ifdef __ELF__
-# define LINUX_DATA_START
-# define DYNAMIC_LOADING
-# else
- Linux Sparc non elf ?
-# endif
- extern int _end;
-# define DATAEND (&_end)
-# define SVR4
-# define STACKBOTTOM ((ptr_t) 0xf0000000)
-# endif
-# ifdef OPENBSD
-# define OS_TYPE "OPENBSD"
-# define STACKBOTTOM ((ptr_t) 0xf8000000)
-# define DATASTART ((ptr_t)(&etext))
-# endif
-# endif
-
-# ifdef I386
-# define MACH_TYPE "I386"
-# define ALIGNMENT 4 /* Appears to hold for all "32 bit" compilers */
- /* except Borland. The -a4 option fixes */
- /* Borland. */
- /* Ivan Demakov: For Watcom the option is -zp4. */
-# ifndef SMALL_CONFIG
-# define ALIGN_DOUBLE /* Not strictly necessary, but may give speed */
- /* improvement on Pentiums. */
-# endif
-# ifdef SEQUENT
-# define OS_TYPE "SEQUENT"
- extern int etext;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
-# define STACKBOTTOM ((ptr_t) 0x3ffff000)
-# endif
-# ifdef SUNOS5
-# define OS_TYPE "SUNOS5"
- extern int etext, _start;
- extern char * GC_SysVGetDataStart();
-# define DATASTART GC_SysVGetDataStart(0x1000, &etext)
-# define STACKBOTTOM ((ptr_t)(&_start))
-/** At least in Solaris 2.5, PROC_VDB gives wrong values for dirty bits. */
-/*# define PROC_VDB*/
-# define DYNAMIC_LOADING
-# ifndef USE_MMAP
-# define USE_MMAP
-# endif
-# ifdef USE_MMAP
-# define HEAP_START (ptr_t)0x40000000
-# else
-# define HEAP_START DATAEND
-# endif
-# endif
-# ifdef SCO
-# define OS_TYPE "SCO"
- extern int etext;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0x3fffff) \
- & ~0x3fffff) \
- +((word)&etext & 0xfff))
-# define STACKBOTTOM ((ptr_t) 0x7ffffffc)
-# endif
-# ifdef SCO_ELF
-# define OS_TYPE "SCO_ELF"
- extern int etext;
-# define DATASTART ((ptr_t)(&etext))
-# define STACKBOTTOM ((ptr_t) 0x08048000)
-# define DYNAMIC_LOADING
-# define ELF_CLASS ELFCLASS32
-# endif
-# ifdef LINUX
-# define OS_TYPE "LINUX"
-# define LINUX_STACKBOTTOM
-# if 0
-# define HEURISTIC1
-# undef STACK_GRAN
-# define STACK_GRAN 0x10000000
- /* STACKBOTTOM is usually 0xc0000000, but this changes with */
- /* different kernel configurations. In particular, systems */
- /* with 2GB physical memory will usually move the user */
- /* address space limit, and hence initial SP to 0x80000000. */
-# endif
-# if !defined(LINUX_THREADS) || !defined(REDIRECT_MALLOC)
-# define MPROTECT_VDB
-# else
- /* We seem to get random errors in incremental mode, */
- /* possibly because Linux threads is itself a malloc client */
- /* and can't deal with the signals. */
-# endif
-# ifdef __ELF__
-# define DYNAMIC_LOADING
-# ifdef UNDEFINED /* includes ro data */
- extern int _etext;
-# define DATASTART ((ptr_t)((((word) (&_etext)) + 0xfff) & ~0xfff))
-# endif
-# include <features.h>
-# if defined(__GLIBC__) && __GLIBC__ >= 2
-# define LINUX_DATA_START
-# else
- extern char **__environ;
-# define DATASTART ((ptr_t)(&__environ))
- /* hideous kludge: __environ is the first */
- /* word in crt0.o, and delimits the start */
- /* of the data segment, no matter which */
- /* ld options were passed through. */
- /* We could use _etext instead, but that */
- /* would include .rodata, which may */
- /* contain large read-only data tables */
- /* that we'd rather not scan. */
-# endif
- extern int _end;
-# define DATAEND (&_end)
-# else
- extern int etext;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
-# endif
-# ifdef USE_I686_PREFETCH
-# define PREFETCH(x) \
- __asm__ __volatile__ (" prefetchnta %0": : "m"(*(char *)(x)))
- /* Empirically prefetcht0 is much more effective at reducing */
- /* cache miss stalls for the targetted load instructions. But it */
- /* seems to interfere enough with other cache traffic that the net */
- /* result is worse than prefetchnta. */
-# if 0
- /* Using prefetches for write seems to have a slight negative */
- /* impact on performance, at least for a PIII/500. */
-# define PREFETCH_FOR_WRITE(x) \
- __asm__ __volatile__ (" prefetcht0 %0": : "m"(*(char *)(x)))
-# endif
-# endif
-# ifdef USE_3DNOW_PREFETCH
-# define PREFETCH(x) \
- __asm__ __volatile__ (" prefetch %0": : "m"(*(char *)(x)))
-# define PREFETCH_FOR_WRITE(x)
- __asm__ __volatile__ (" prefetchw %0": : "m"(*(char *)(x)))
-# endif
-# endif
-# ifdef CYGWIN32
-# define OS_TYPE "CYGWIN32"
- extern int _data_start__;
- extern int _data_end__;
- extern int _bss_start__;
- extern int _bss_end__;
- /* For binutils 2.9.1, we have */
- /* DATASTART = _data_start__ */
- /* DATAEND = _bss_end__ */
- /* whereas for some earlier versions it was */
- /* DATASTART = _bss_start__ */
- /* DATAEND = _data_end__ */
- /* To get it right for both, we take the */
- /* minumum/maximum of the two. */
-# define MAX(x,y) ((x) > (y) ? (x) : (y))
-# define MIN(x,y) ((x) < (y) ? (x) : (y))
-# define DATASTART ((ptr_t) MIN(&_data_start__, &_bss_start__))
-# define DATAEND ((ptr_t) MAX(&_data_end__, &_bss_end__))
-# undef STACK_GRAN
-# define STACK_GRAN 0x10000
-# define HEURISTIC1
-# endif
-# ifdef OS2
-# define OS_TYPE "OS2"
- /* STACKBOTTOM and DATASTART are handled specially in */
- /* os_dep.c. OS2 actually has the right */
- /* system call! */
-# define DATAEND /* not needed */
-# endif
-# ifdef MSWIN32
-# define OS_TYPE "MSWIN32"
- /* STACKBOTTOM and DATASTART are handled specially in */
- /* os_dep.c. */
-# ifndef __WATCOMC__
-# define MPROTECT_VDB
-# endif
-# define DATAEND /* not needed */
-# endif
-# ifdef DJGPP
-# define OS_TYPE "DJGPP"
-# include "stubinfo.h"
- extern int etext;
- extern int _stklen;
- extern int __djgpp_stack_limit;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0x1ff) & ~0x1ff))
-/* # define STACKBOTTOM ((ptr_t)((word) _stubinfo + _stubinfo->size \
- + _stklen)) */
-# define STACKBOTTOM ((ptr_t)((word) __djgpp_stack_limit + _stklen))
- /* This may not be right. */
-# endif
-# ifdef OPENBSD
-# define OS_TYPE "OPENBSD"
-# endif
-# ifdef FREEBSD
-# define OS_TYPE "FREEBSD"
-# define MPROTECT_VDB
-# endif
-# ifdef NETBSD
-# define OS_TYPE "NETBSD"
-# endif
-# ifdef THREE86BSD
-# define OS_TYPE "THREE86BSD"
-# endif
-# ifdef BSDI
-# define OS_TYPE "BSDI"
-# endif
-# if defined(OPENBSD) || defined(FREEBSD) || defined(NETBSD) \
- || defined(THREE86BSD) || defined(BSDI)
-# define HEURISTIC2
- extern char etext;
-# define DATASTART ((ptr_t)(&etext))
-# endif
-# ifdef NEXT
-# define OS_TYPE "NEXT"
-# define DATASTART ((ptr_t) get_etext())
-# define STACKBOTTOM ((ptr_t)0xc0000000)
-# define DATAEND /* not needed */
-# endif
-# ifdef DOS4GW
-# define OS_TYPE "DOS4GW"
- extern long __nullarea;
- extern char _end;
- extern char *_STACKTOP;
- /* Depending on calling conventions Watcom C either precedes
- or does not precedes with undescore names of C-variables.
- Make sure startup code variables always have the same names. */
- #pragma aux __nullarea "*";
- #pragma aux _end "*";
-# define STACKBOTTOM ((ptr_t) _STACKTOP)
- /* confused? me too. */
-# define DATASTART ((ptr_t) &__nullarea)
-# define DATAEND ((ptr_t) &_end)
-# endif
-# ifdef GNU
-# define OS_TYPE "GNU"
-# endif
-# endif
-
-# ifdef NS32K
-# define MACH_TYPE "NS32K"
-# define ALIGNMENT 4
- extern char **environ;
-# define DATASTART ((ptr_t)(&environ))
- /* hideous kludge: environ is the first */
- /* word in crt0.o, and delimits the start */
- /* of the data segment, no matter which */
- /* ld options were passed through. */
-# define STACKBOTTOM ((ptr_t) 0xfffff000) /* for Encore */
-# endif
-
-# ifdef MIPS
-# define MACH_TYPE "MIPS"
-# ifdef LINUX
-# define CPP_WORDSZ _MIPS_SZPTR
-# define OS_TYPE "LINUX"
-# define ALIGNMENT 4
-# define ALIGN_DOUBLE
- extern int _fdata;
-# define DATASTART ((ptr_t)(&_fdata))
- extern int _end;
-# define DATAEND ((ptr_t)(&_end))
-# define STACKBOTTOM ((ptr_t)0x7fff8000)
-# define USE_GENERIC_PUSH_REGS 1
-# define DYNAMIC_LOADING
-# endif /* Linux */
-# ifdef ULTRIX
-# define HEURISTIC2
-# define DATASTART (ptr_t)0x10000000
- /* Could probably be slightly higher since */
- /* startup code allocates lots of stuff. */
-# define OS_TYPE "ULTRIX"
-# define ALIGNMENT 4
-# endif
-# ifdef RISCOS
-# define HEURISTIC2
-# define DATASTART (ptr_t)0x10000000
-# define OS_TYPE "RISCOS"
-# define ALIGNMENT 4 /* Required by hardware */
-# endif
-# ifdef IRIX5
-# define HEURISTIC2
- extern int _fdata;
-# define DATASTART ((ptr_t)(&_fdata))
-# ifdef USE_MMAP
-# define HEAP_START (ptr_t)0x30000000
-# else
-# define HEAP_START DATASTART
-# endif
- /* Lowest plausible heap address. */
- /* In the MMAP case, we map there. */
- /* In either case it is used to identify */
- /* heap sections so they're not */
- /* considered as roots. */
-# define OS_TYPE "IRIX5"
-# define MPROTECT_VDB
-# ifdef _MIPS_SZPTR
-# define CPP_WORDSZ _MIPS_SZPTR
-# define ALIGNMENT (_MIPS_SZPTR/8)
-# if CPP_WORDSZ != 64
-# define ALIGN_DOUBLE
-# endif
-# else
-# define ALIGNMENT 4
-# define ALIGN_DOUBLE
-# endif
-# define DYNAMIC_LOADING
-# endif
-# endif
-
-# ifdef RS6000
-# define MACH_TYPE "RS6000"
-# define ALIGNMENT 4
-# define DATASTART ((ptr_t)0x20000000)
- extern int errno;
-# define STACKBOTTOM ((ptr_t)((ulong)&errno))
-# define DYNAMIC_LOADING
- /* For really old versions of AIX, this may have to be removed. */
-# endif
-
-# ifdef HP_PA
- /* OS is assumed to be HP/UX */
-# define MACH_TYPE "HP_PA"
-# define OS_TYPE "HPUX"
-# ifdef __LP64__
-# define CPP_WORDSZ 64
-# define ALIGNMENT 8
-# else
-# define CPP_WORDSZ 32
-# define ALIGNMENT 4
-# define ALIGN_DOUBLE
-# endif
- extern int __data_start;
-# define DATASTART ((ptr_t)(&__data_start))
-# if 0
- /* The following appears to work for 7xx systems running HP/UX */
- /* 9.xx Furthermore, it might result in much faster */
- /* collections than HEURISTIC2, which may involve scanning */
- /* segments that directly precede the stack. It is not the */
- /* default, since it may not work on older machine/OS */
- /* combinations. (Thanks to Raymond X.T. Nijssen for uncovering */
- /* this.) */
-# define STACKBOTTOM ((ptr_t) 0x7b033000) /* from /etc/conf/h/param.h */
-# else
- /* Gustavo Rodriguez-Rivera suggested changing HEURISTIC2 */
- /* to this. We'll probably do this on other platforms, too. */
- /* For now I'll use it where I can test it. */
- extern char ** environ;
-# define STACKBOTTOM ((ptr_t)environ)
-# endif
-# ifndef SCM_STACK_GROWS_UP /* don't fight with scmconfig.h */
-# define SCM_STACK_GROWS_UP 1
-# endif
-# define DYNAMIC_LOADING
-# ifndef HPUX_THREADS
-# define MPROTECT_VDB
-# endif
-# include <unistd.h>
-# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE)
-# endif
-
-# ifdef ALPHA
-# define MACH_TYPE "ALPHA"
-# define ALIGNMENT 8
-# define USE_GENERIC_PUSH_REGS
- /* Gcc and probably the DEC/Compaq compiler spill pointers to preserved */
- /* fp registers in some cases when the target is a 21264. The assembly */
- /* code doesn't handle that yet, and version dependencies make that a */
- /* bit tricky. Do the easy thing for now. */
-# ifdef OSF1
-# define OS_TYPE "OSF1"
-# define DATASTART ((ptr_t) 0x140000000)
- extern int _end;
-# define DATAEND ((ptr_t) &_end)
-# define HEURISTIC2
- /* Normally HEURISTIC2 is too conervative, since */
- /* the text segment immediately follows the stack. */
- /* Hence we give an upper pound. */
- extern int __start;
-# define HEURISTIC2_LIMIT ((ptr_t)((word)(&__start) & ~(getpagesize()-1)))
-# define CPP_WORDSZ 64
-# define MPROTECT_VDB
-# define DYNAMIC_LOADING
-# endif
-# ifdef LINUX
-# define OS_TYPE "LINUX"
-# define CPP_WORDSZ 64
-# define STACKBOTTOM ((ptr_t) 0x120000000)
-# ifdef __ELF__
-# define LINUX_DATA_START
-# define DYNAMIC_LOADING
- /* This doesn't work if the collector is in a dynamic library. */
-# else
-# define DATASTART ((ptr_t) 0x140000000)
-# endif
- extern int _end;
-# define DATAEND (&_end)
-# define MPROTECT_VDB
- /* Has only been superficially tested. May not */
- /* work on all versions. */
-# endif
-# endif
-
-# ifdef IA64
-# define MACH_TYPE "IA64"
-# define ALIGN_DOUBLE
- /* Requires 16 byte alignment for malloc */
-# define ALIGNMENT 8
-# define USE_GENERIC_PUSH_REGS
- /* We need to get preserved registers in addition to register windows. */
- /* That's easiest to do with setjmp. */
-# ifdef HPUX
- --> needs work
-# endif
-# ifdef LINUX
-# define OS_TYPE "LINUX"
-# define CPP_WORDSZ 64
- /* This should really be done through /proc, but that */
- /* requires we run on an IA64 kernel. */
-# define STACKBOTTOM ((ptr_t) 0xa000000000000000l)
- /* We also need the base address of the register stack */
- /* backing store. There is probably a better way to */
- /* get that, too ... */
-# define BACKING_STORE_BASE ((ptr_t) 0x9fffffff80000000l)
-# if 1
-# define SEARCH_FOR_DATA_START
-# define DATASTART GC_data_start
-# else
- extern int data_start;
-# define DATASTART ((ptr_t)(&data_start))
-# endif
-# define DYNAMIC_LOADING
-# define MPROTECT_VDB
- /* Requires Linux 2.3.47 or later. */
- extern int _end;
-# define DATAEND (&_end)
-# define PREFETCH(x) \
- __asm__ (" lfetch [%0]": : "r"((void *)(x)))
-# define PREFETCH_FOR_WRITE(x) \
- __asm__ (" lfetch.excl [%0]": : "r"((void *)(x)))
-# define CLEAR_DOUBLE(x) \
- __asm__ (" stf.spill [%0]=f0": : "r"((void *)(x)))
-# endif
-# endif
-
-# ifdef M88K
-# define MACH_TYPE "M88K"
-# define ALIGNMENT 4
-# define ALIGN_DOUBLE
- extern int etext;
-# ifdef CX_UX
-# define OS_TYPE "CX_UX"
-# define DATASTART ((((word)&etext + 0x3fffff) & ~0x3fffff) + 0x10000)
-# endif
-# ifdef DGUX
-# define OS_TYPE "DGUX"
- extern char * GC_SysVGetDataStart();
-# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &etext)
-# endif
-# define STACKBOTTOM ((char*)0xf0000000) /* determined empirically */
-# endif
-
-# ifdef S370
-# define MACH_TYPE "S370"
-# define OS_TYPE "UTS4"
-# define ALIGNMENT 4 /* Required by hardware */
- extern int etext;
- extern int _etext;
- extern int _end;
- extern char * GC_SysVGetDataStart();
-# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &_etext)
-# define DATAEND (&_end)
-# define HEURISTIC2
-# endif
-
-# if defined(PJ)
-# define ALIGNMENT 4
- extern int _etext;
-# define DATASTART ((ptr_t)(&_etext))
-# define HEURISTIC1
-# endif
-
-# ifdef ARM32
-# define CPP_WORDSZ 32
-# define MACH_TYPE "ARM32"
-# define ALIGNMENT 4
-# ifdef NETBSD
-# define OS_TYPE "NETBSD"
-# define HEURISTIC2
- extern char etext;
-# define DATASTART ((ptr_t)(&etext))
-# define USE_GENERIC_PUSH_REGS
-# endif
-# ifdef LINUX
-# define OS_TYPE "LINUX"
-# define HEURISTIC1
-# undef STACK_GRAN
-# define STACK_GRAN 0x10000000
-# define USE_GENERIC_PUSH_REGS
-# ifdef __ELF__
-# define DYNAMIC_LOADING
-# include <features.h>
-# if defined(__GLIBC__) && __GLIBC__ >= 2
-# define LINUX_DATA_START
-# else
- extern char **__environ;
-# define DATASTART ((ptr_t)(&__environ))
- /* hideous kludge: __environ is the first */
- /* word in crt0.o, and delimits the start */
- /* of the data segment, no matter which */
- /* ld options were passed through. */
- /* We could use _etext instead, but that */
- /* would include .rodata, which may */
- /* contain large read-only data tables */
- /* that we'd rather not scan. */
-# endif
- extern int _end;
-# define DATAEND (&_end)
-# else
- extern int etext;
-# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
-# endif
-# endif
-#endif
-
-#ifdef LINUX_DATA_START
- /* Some Linux distributions arrange to define __data_start. Some */
- /* define data_start as a weak symbol. The latter is technically */
- /* broken, since the user program may define data_start, in which */
- /* case we lose. Nonetheless, we try both, prefering __data_start. */
- /* We assume gcc. */
-# pragma weak __data_start
- extern int __data_start;
-# pragma weak data_start
- extern int data_start;
-# define DATASTART ((ptr_t)(&__data_start != 0? &__data_start : &data_start))
-#endif
-
-# if SCM_STACK_GROWS_UP
-# define STACK_GROWS_DOWN 0
-# else
-# define STACK_GROWS_DOWN 1
-#endif
-
-# ifndef CPP_WORDSZ
-# define CPP_WORDSZ 32
-# endif
-
-# ifndef OS_TYPE
-# define OS_TYPE ""
-# endif
-
-# ifndef DATAEND
- extern int end;
-# define DATAEND (&end)
-# endif
-
-# if defined(SVR4) && !defined(GETPAGESIZE)
-# include <unistd.h>
-# define GETPAGESIZE() sysconf(_SC_PAGESIZE)
-# endif
-
-# ifndef GETPAGESIZE
-# if defined(SUNOS5) || defined(IRIX5)
-# include <unistd.h>
-# endif
-# define GETPAGESIZE() getpagesize()
-# endif
-
-# if defined(SUNOS5) || defined(DRSNX) || defined(UTS4)
- /* OS has SVR4 generic features. Probably others also qualify. */
-# define SVR4
-# endif
-
-# if defined(SUNOS5) || defined(DRSNX)
- /* OS has SUNOS5 style semi-undocumented interface to dynamic */
- /* loader. */
-# define SUNOS5DL
- /* OS has SUNOS5 style signal handlers. */
-# define SUNOS5SIGS
-# endif
-
-# if defined(HPUX)
-# define SUNOS5SIGS
-# endif
-
-# if CPP_WORDSZ != 32 && CPP_WORDSZ != 64
- -> bad word size
-# endif
-
-# ifdef PCR
-# undef DYNAMIC_LOADING
-# undef STACKBOTTOM
-# undef HEURISTIC1
-# undef HEURISTIC2
-# undef PROC_VDB
-# undef MPROTECT_VDB
-# define PCR_VDB
-# endif
-
-# ifdef SRC_M3
-/* Postponed for now. */
-# undef PROC_VDB
-# undef MPROTECT_VDB
-# endif
-
-# ifdef SMALL_CONFIG
-/* Presumably not worth the space it takes. */
-# undef PROC_VDB
-# undef MPROTECT_VDB
-# endif
-
-# ifdef USE_MUNMAP
-# undef MPROTECT_VDB /* Can't deal with address space holes. */
-# endif
-
-# if !defined(PCR_VDB) && !defined(PROC_VDB) && !defined(MPROTECT_VDB)
-# define DEFAULT_VDB
-# endif
-
-# ifndef PREFETCH
-# define PREFETCH(x)
-# define NO_PREFETCH
-# endif
-
-# ifndef PREFETCH_FOR_WRITE
-# define PREFETCH_FOR_WRITE(x)
-# define NO_PREFETCH_FOR_WRITE
-# endif
-
-# ifndef CACHE_LINE_SIZE
-# define CACHE_LINE_SIZE 32 /* Wild guess */
-# endif
-
-# ifndef CLEAR_DOUBLE
-# define CLEAR_DOUBLE(x) \
- ((word*)x)[0] = 0; \
- ((word*)x)[1] = 0;
-# endif /* CLEAR_DOUBLE */
-
-# if defined(_SOLARIS_PTHREADS) && !defined(SOLARIS_THREADS)
-# define SOLARIS_THREADS
-# endif
-# if defined(IRIX_THREADS) && !defined(IRIX5)
---> inconsistent configuration
-# endif
-# if defined(IRIX_JDK_THREADS) && !defined(IRIX5)
---> inconsistent configuration
-# endif
-# if defined(LINUX_THREADS) && !defined(LINUX)
---> inconsistent configuration
-# endif
-# if defined(SOLARIS_THREADS) && !defined(SUNOS5)
---> inconsistent configuration
-# endif
-# if defined(HPUX_THREADS) && !defined(HPUX)
---> inconsistent configuration
-# endif
-# if defined(PCR) || defined(SRC_M3) || \
- defined(SOLARIS_THREADS) || defined(WIN32_THREADS) || \
- defined(IRIX_THREADS) || defined(LINUX_THREADS) || \
- defined(IRIX_JDK_THREADS) || defined(HPUX_THREADS)
-# define THREADS
-# endif
-
-# if defined(HP_PA) || defined(M88K) || defined(POWERPC) \
- || (defined(I386) && defined(OS2)) || defined(UTS4) || defined(LINT)
- /* Use setjmp based hack to mark from callee-save registers. */
-# define USE_GENERIC_PUSH_REGS
-# endif
-# if defined(SPARC) && !defined(LINUX)
-# define SAVE_CALL_CHAIN
-# define ASM_CLEAR_CODE /* Stack clearing is crucial, and we */
- /* include assembly code to do it well. */
-# endif
-
-# if defined(LINUX) && !defined(POWERPC)
-
-# if 0
-# include <linux/version.h>
-# if (LINUX_VERSION_CODE <= 0x10400)
- /* Ugly hack to get struct sigcontext_struct definition. Required */
- /* for some early 1.3.X releases. Will hopefully go away soon. */
- /* in some later Linux releases, asm/sigcontext.h may have to */
- /* be included instead. */
-# define __KERNEL__
-# include <asm/signal.h>
-# undef __KERNEL__
-# endif
-
-# else
-
- /* Kernels prior to 2.1.1 defined struct sigcontext_struct instead of */
- /* struct sigcontext. libc6 (glibc2) uses "struct sigcontext" in */
- /* prototypes, so we have to include the top-level sigcontext.h to */
- /* make sure the former gets defined to be the latter if appropriate. */
-# include <features.h>
-# if 2 <= __GLIBC__
-# if 2 == __GLIBC__ && 0 == __GLIBC_MINOR__
- /* glibc 2.1 no longer has sigcontext.h. But signal.h */
- /* has the right declaration for glibc 2.1. */
-# include <sigcontext.h>
-# endif /* 0 == __GLIBC_MINOR__ */
-# else /* not 2 <= __GLIBC__ */
- /* libc5 doesn't have <sigcontext.h>: go directly with the kernel */
- /* one. Check LINUX_VERSION_CODE to see which we should reference. */
-# include <asm/sigcontext.h>
-# endif /* 2 <= __GLIBC__ */
-# endif
-# endif
-# if !defined(OS2) && !defined(PCR) && !defined(AMIGA) && !defined(MACOS)
-# include <sys/types.h>
-# if !defined(MSWIN32) && !defined(SUNOS4)
-# include <unistd.h>
-# endif
-# endif
-
-# include <signal.h>
-
-/* Blatantly OS dependent routines, except for those that are related */
-/* to dynamic loading. */
-
-# if !defined(THREADS) && !defined(STACKBOTTOM) && defined(HEURISTIC2)
-# define NEED_FIND_LIMIT
-# endif
-
-# if defined(IRIX_THREADS) || defined(HPUX_THREADS)
-# define NEED_FIND_LIMIT
-# endif
-
-# if (defined(SUNOS4) && defined(DYNAMIC_LOADING)) && !defined(PCR)
-# define NEED_FIND_LIMIT
-# endif
-
-# if (defined(SVR4) || defined(AUX) || defined(DGUX)) && !defined(PCR)
-# define NEED_FIND_LIMIT
-# endif
-
-# if defined(LINUX) && \
- (defined(POWERPC) || defined(SPARC) || defined(ALPHA) || defined(IA64) \
- || defined(MIPS))
-# define NEED_FIND_LIMIT
-# endif
-
-#ifdef NEED_FIND_LIMIT
-# include <setjmp.h>
-#endif
-
-#ifdef FREEBSD
-# include <machine/trap.h>
-#endif
-
-#ifdef AMIGA
-# include <proto/exec.h>
-# include <proto/dos.h>
-# include <dos/dosextens.h>
-# include <workbench/startup.h>
-#endif
-
-#ifdef MSWIN32
-# define WIN32_LEAN_AND_MEAN
-# define NOSERVICE
-# include <windows.h>
-#endif
-
-#ifdef MACOS
-# include <Processes.h>
-#endif
-
-#ifdef IRIX5
-# include <sys/uio.h>
-# include <malloc.h> /* for locking */
-#endif
-#ifdef USE_MMAP
-# include <sys/types.h>
-# include <sys/mman.h>
-# include <sys/stat.h>
-# include <fcntl.h>
-#endif
-
-#ifdef SUNOS5SIGS
-# include <sys/siginfo.h>
-# undef setjmp
-# undef longjmp
-# define setjmp(env) sigsetjmp(env, 1)
-# define longjmp(env, val) siglongjmp(env, val)
-# define jmp_buf sigjmp_buf
-#endif
-
-#ifdef DJGPP
- /* Apparently necessary for djgpp 2.01. May casuse problems with */
- /* other versions. */
- typedef long unsigned int caddr_t;
-#endif
-
-#ifdef PCR
-# include "il/PCR_IL.h"
-# include "th/PCR_ThCtl.h"
-# include "mm/PCR_MM.h"
-#endif
-
-#if !defined(NO_EXECUTE_PERMISSION)
-# define OPT_PROT_EXEC PROT_EXEC
-#else
-# define OPT_PROT_EXEC 0
-#endif
-
-# ifdef OS2
-
-# include <stddef.h>
-
-# if !defined(__IBMC__) && !defined(__WATCOMC__) /* e.g. EMX */
-
-# else /* IBM's compiler */
-
-/* A kludge to get around what appears to be a header file bug */
-# ifndef WORD
-# define WORD unsigned short
-# endif
-# ifndef DWORD
-# define DWORD unsigned long
-# endif
-
-# define EXE386 1
-# include <newexe.h>
-# include <exe386.h>
-
-# endif /* __IBMC__ */
-
-# define INCL_DOSEXCEPTIONS
-# define INCL_DOSPROCESS
-# define INCL_DOSERRORS
-# define INCL_DOSMODULEMGR
-# define INCL_DOSMEMMGR
-# include <os2.h>
-
-# endif /*!OS/2 */
-
-/*
- * Find the base of the stack.
- * Used only in single-threaded environment.
- * With threads, GC_mark_roots needs to know how to do this.
- * Called with allocator lock held.
- */
-# ifdef MSWIN32
-# define is_writable(prot) ((prot) == PAGE_READWRITE \
- || (prot) == PAGE_WRITECOPY \
- || (prot) == PAGE_EXECUTE_READWRITE \
- || (prot) == PAGE_EXECUTE_WRITECOPY)
-/* Return the number of bytes that are writable starting at p. */
-/* The pointer p is assumed to be page aligned. */
-/* If base is not 0, *base becomes the beginning of the */
-/* allocation region containing p. */
-static word GC_get_writable_length(ptr_t p, ptr_t *base)
-{
- MEMORY_BASIC_INFORMATION buf;
- word result;
- word protect;
-
- result = VirtualQuery(p, &buf, sizeof(buf));
- if (result != sizeof(buf)) ABORT("Weird VirtualQuery result");
- if (base != 0) *base = (ptr_t)(buf.AllocationBase);
- protect = (buf.Protect & ~(PAGE_GUARD | PAGE_NOCACHE));
- if (!is_writable(protect)) {
- return(0);
- }
- if (buf.State != MEM_COMMIT) return(0);
- return(buf.RegionSize);
-}
-
-void *scm_get_stack_base()
-{
- int dummy;
- ptr_t sp = (ptr_t)(&dummy);
- ptr_t trunc_sp;
- word size;
- static word GC_page_size = 0;
- if (!GC_page_size) {
- SYSTEM_INFO sysinfo;
- GetSystemInfo(&sysinfo);
- GC_page_size = sysinfo.dwPageSize;
- }
- trunc_sp = (ptr_t)((word)sp & ~(GC_page_size - 1));
- size = GC_get_writable_length(trunc_sp, 0);
- return(trunc_sp + size);
-}
-
-
-# else
-
-# ifdef OS2
-
-void *scm_get_stack_base()
-{
- PTIB ptib;
- PPIB ppib;
-
- if (DosGetInfoBlocks(&ptib, &ppib) != NO_ERROR) {
- GC_err_printf0("DosGetInfoBlocks failed\n");
- ABORT("DosGetInfoBlocks failed\n");
- }
- return((ptr_t)(ptib -> tib_pstacklimit));
-}
-
-# else
-
-# ifdef AMIGA
-
-void *scm_get_stack_base()
-{
- struct Process *proc = (struct Process*)SysBase->ThisTask;
-
- /* Reference: Amiga Guru Book Pages: 42,567,574 */
- if (proc->pr_Task.tc_Node.ln_Type==NT_PROCESS
- && proc->pr_CLI != NULL) {
- /* first ULONG is StackSize */
- /*longPtr = proc->pr_ReturnAddr;
- size = longPtr[0];*/
-
- return (char *)proc->pr_ReturnAddr + sizeof(ULONG);
- } else {
- return (char *)proc->pr_Task.tc_SPUpper;
- }
-}
-
-#if 0 /* old version */
-void *scm_get_stack_base()
-{
- extern struct WBStartup *_WBenchMsg;
- extern long __base;
- extern long __stack;
- struct Task *task;
- struct Process *proc;
- struct CommandLineInterface *cli;
- long size;
-
- if ((task = FindTask(0)) == 0) {
- GC_err_puts("Cannot find own task structure\n");
- ABORT("task missing");
- }
- proc = (struct Process *)task;
- cli = BADDR(proc->pr_CLI);
-
- if (_WBenchMsg != 0 || cli == 0) {
- size = (char *)task->tc_SPUpper - (char *)task->tc_SPLower;
- } else {
- size = cli->cli_DefaultStack * 4;
- }
- return (ptr_t)(__base + GC_max(size, __stack));
-}
-#endif /* 0 */
-
-# else /* !AMIGA, !OS2, ... */
-
-# ifdef NEED_FIND_LIMIT
- /* Some tools to implement HEURISTIC2 */
-# define MIN_PAGE_SIZE 256 /* Smallest conceivable page size, bytes */
- /* static */ jmp_buf GC_jmp_buf;
-
- /*ARGSUSED*/
- static void GC_fault_handler(sig)
- int sig;
- {
- longjmp(GC_jmp_buf, 1);
- }
-
-# ifdef __STDC__
- typedef void (*handler)(int);
-# else
- typedef void (*handler)();
-# endif
-
-# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1)
- static struct sigaction old_segv_act;
-# if defined(_sigargs) || defined(HPUX) /* !Irix6.x */
- static struct sigaction old_bus_act;
-# endif
-# else
- static handler old_segv_handler, old_bus_handler;
-# endif
-
- static void GC_setup_temporary_fault_handler()
- {
-# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1)
- struct sigaction act;
-
- act.sa_handler = GC_fault_handler;
- act.sa_flags = SA_RESTART | SA_NODEFER;
- /* The presence of SA_NODEFER represents yet another gross */
- /* hack. Under Solaris 2.3, siglongjmp doesn't appear to */
- /* interact correctly with -lthread. We hide the confusion */
- /* by making sure that signal handling doesn't affect the */
- /* signal mask. */
-
- (void) sigemptyset(&act.sa_mask);
-# ifdef IRIX_THREADS
- /* Older versions have a bug related to retrieving and */
- /* and setting a handler at the same time. */
- (void) sigaction(SIGSEGV, 0, &old_segv_act);
- (void) sigaction(SIGSEGV, &act, 0);
-# else
- (void) sigaction(SIGSEGV, &act, &old_segv_act);
-# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \
- || defined(HPUX)
- /* Under Irix 5.x or HP/UX, we may get SIGBUS. */
- /* Pthreads doesn't exist under Irix 5.x, so we */
- /* don't have to worry in the threads case. */
- (void) sigaction(SIGBUS, &act, &old_bus_act);
-# endif
-# endif /* IRIX_THREADS */
-# else
- old_segv_handler = signal(SIGSEGV, GC_fault_handler);
-# ifdef SIGBUS
- old_bus_handler = signal(SIGBUS, GC_fault_handler);
-# endif
-# endif
- }
-
- static void GC_reset_fault_handler()
- {
-# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1)
- (void) sigaction(SIGSEGV, &old_segv_act, 0);
-# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \
- || defined(HPUX)
- (void) sigaction(SIGBUS, &old_bus_act, 0);
-# endif
-# else
- (void) signal(SIGSEGV, old_segv_handler);
-# ifdef SIGBUS
- (void) signal(SIGBUS, old_bus_handler);
-# endif
-# endif
- }
-
- /* Single argument version, robust against whole program analysis. */
- static void
- GC_noop1(x)
- word x;
- {
- static VOLATILE word sink;
- sink = x;
- }
-
- /* Return the first nonaddressible location > p (up) or */
- /* the smallest location q s.t. [q,p] is addressible (!up). */
- static ptr_t GC_find_limit(p, up)
- ptr_t p;
- GC_bool up;
- {
- static VOLATILE ptr_t result;
- /* Needs to be static, since otherwise it may not be */
- /* preserved across the longjmp. Can safely be */
- /* static since it's only called once, with the */
- /* allocation lock held. */
-
-
- GC_setup_temporary_fault_handler();
- if (setjmp(GC_jmp_buf) == 0) {
- result = (ptr_t)(((word)(p))
- & ~(MIN_PAGE_SIZE-1));
- for (;;) {
- if (up) {
- result += MIN_PAGE_SIZE;
- } else {
- result -= MIN_PAGE_SIZE;
- }
- GC_noop1((word)(*result));
- }
- }
- GC_reset_fault_handler();
- if (!up) {
- result += MIN_PAGE_SIZE;
- }
- return(result);
- }
-
-# endif
-
-#ifdef LINUX_STACKBOTTOM
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <fcntl.h>
-
-# define STAT_SKIP 27 /* Number of fields preceding startstack */
- /* field in /proc/self/stat */
-
- static ptr_t GC_linux_stack_base(void)
- {
- /* We read the stack base value from /proc/self/stat. We do this */
- /* using direct I/O system calls in order to avoid calling malloc */
- /* in case REDIRECT_MALLOC is defined. */
-# define STAT_BUF_SIZE 4096
-# ifdef USE_LD_WRAP
-# define STAT_READ __real_read
-# else
-# define STAT_READ read
-# endif
- char stat_buf[STAT_BUF_SIZE];
- int f;
- char c;
- word result = 0;
- size_t i, buf_offset = 0;
-
- f = open("/proc/self/stat", O_RDONLY);
- if (f < 0 || STAT_READ(f, stat_buf, STAT_BUF_SIZE) < 2 * STAT_SKIP) {
- ABORT("Couldn't read /proc/self/stat");
- }
- c = stat_buf[buf_offset++];
- /* Skip the required number of fields. This number is hopefully */
- /* constant across all Linux implementations. */
- for (i = 0; i < STAT_SKIP; ++i) {
- while (isspace(c)) c = stat_buf[buf_offset++];
- while (!isspace(c)) c = stat_buf[buf_offset++];
- }
- while (isspace(c)) c = stat_buf[buf_offset++];
- while (isdigit(c)) {
- result *= 10;
- result += c - '0';
- c = stat_buf[buf_offset++];
- }
- close(f);
- if (result < 0x10000000) ABORT("Absurd stack bottom value");
- return (ptr_t)result;
- }
-
-#endif /* LINUX_STACKBOTTOM */
-
-void *scm_get_stack_base()
-{
- word dummy;
- void *result;
-
- result = &dummy; /* initialize to silence compiler */
-
-# define STACKBOTTOM_ALIGNMENT_M1 ((word)STACK_GRAN - 1)
-
-# ifdef STACKBOTTOM
- return(STACKBOTTOM);
-# else
-# ifdef HEURISTIC1
-# if STACK_GROWS_DOWN
- result = (ptr_t)((((word)(&dummy))
- + STACKBOTTOM_ALIGNMENT_M1)
- & ~STACKBOTTOM_ALIGNMENT_M1);
-# else
- result = (ptr_t)(((word)(&dummy))
- & ~STACKBOTTOM_ALIGNMENT_M1);
-# endif
-# endif /* HEURISTIC1 */
-# ifdef LINUX_STACKBOTTOM
- result = GC_linux_stack_base();
-# endif
-# ifdef HEURISTIC2
-# if STACK_GROWS_DOWN
- result = GC_find_limit((ptr_t)(&dummy), TRUE);
-# ifdef HEURISTIC2_LIMIT
- if ((ptr_t)result > HEURISTIC2_LIMIT
- && (ptr_t)(&dummy) < HEURISTIC2_LIMIT) {
- result = HEURISTIC2_LIMIT;
- }
-# endif
-# else
- result = GC_find_limit((ptr_t)(&dummy), FALSE);
-# ifdef HEURISTIC2_LIMIT
- if (result < HEURISTIC2_LIMIT
- && (ptr_t)(&dummy) > HEURISTIC2_LIMIT) {
- result = HEURISTIC2_LIMIT;
- }
-# endif
-# endif
-
-# endif /* HEURISTIC2 */
-# if STACK_GROWS_DOWN
- if (result == 0) result = (ptr_t)(signed_word)(-sizeof(ptr_t));
-# endif
- return(result);
-# endif /* STACKBOTTOM */
-}
-
-# endif /* ! AMIGA */
-# endif /* ! OS2 */
-# endif /* ! MSWIN32 */
-
-#endif /* mach_type_known */
-#endif /* ! HAVE_LIBC_STACK_END */
/* GDB interface for Guile
- * Copyright (C) 1996,1997,1999,2000,2001,2002,2004
+ * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
int scm_print_carefully_p;
static SCM gdb_input_port;
-static int port_mark_p, stream_mark_p, string_mark_p;
-
static SCM gdb_output_port;
-static void
-unmark_port (SCM port)
-{
- SCM stream, string;
- port_mark_p = SCM_GC_MARK_P (port);
- SCM_CLEAR_GC_MARK (port);
- stream = SCM_PACK (SCM_STREAM (port));
- stream_mark_p = SCM_GC_MARK_P (stream);
- SCM_CLEAR_GC_MARK (stream);
- string = SCM_CDR (stream);
- string_mark_p = SCM_GC_MARK_P (string);
- SCM_CLEAR_GC_MARK (string);
-}
-
-
-static void
-remark_port (SCM port)
-{
- SCM stream = SCM_PACK (SCM_STREAM (port));
- SCM string = SCM_CDR (stream);
- if (string_mark_p)
- SCM_SET_GC_MARK (string);
- if (stream_mark_p)
- SCM_SET_GC_MARK (stream);
- if (port_mark_p)
- SCM_SET_GC_MARK (port);
-}
-
-
int
gdb_maybe_valid_type_p (SCM value)
{
- return SCM_IMP (value) || scm_in_heap_p (value);
+ return SCM_IMP (value); /* || scm_in_heap_p (value); */ /* FIXME: What to
+ do? */
}
int
gdb_read (char *str)
{
+#if 0
SCM ans;
int status = 0;
RESET_STRING;
/* Need to be restrictive about what to read? */
- if (SCM_GC_P)
+ if (1) /* (SCM_GC_P) */ /* FIXME */
{
char *p;
for (p = str; *p != '\0'; ++p)
}
}
gdb_result = ans;
- /* Protect answer from future GC */
+ /* Protect answer from future GC (FIXME: still needed with BDW-GC?) */
if (SCM_NIMP (ans))
scm_permanent_object (ans);
exit:
remark_port (gdb_input_port);
SCM_END_FOREIGN_BLOCK;
return status;
+#else
+ abort ();
+#endif
}
}
SCM_BEGIN_FOREIGN_BLOCK;
{
- SCM env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
- gdb_result = scm_permanent_object (scm_i_eval_x (exp, env));
+ gdb_result = scm_permanent_object (scm_primitive_eval (exp));
}
SCM_END_FOREIGN_BLOCK;
return 0;
#ifdef STDC_HEADERS
pf ("#define SCM_HAVE_STDC_HEADERS 1 /* 0 or 1 */\n");
pf ("#include <stdlib.h>\n");
-# if HAVE_SYS_TYPES_H
+# ifdef HAVE_SYS_TYPES_H
pf ("#include <sys/types.h>\n");
# endif
-# if HAVE_SYS_STDTYPES_H
+# ifdef HAVE_SYS_STDTYPES_H
pf ("#include <sys/stdtypes.h>\n");
# endif
pf ("#include <stddef.h>\n");
pf ("typedef %s scm_t_uint32;\n", SCM_I_GSC_T_UINT32);
pf ("typedef %s scm_t_intmax;\n", SCM_I_GSC_T_INTMAX);
pf ("typedef %s scm_t_uintmax;\n", SCM_I_GSC_T_UINTMAX);
+ pf ("typedef %s scm_t_intptr;\n", SCM_I_GSC_T_INTPTR);
+ pf ("typedef %s scm_t_uintptr;\n", SCM_I_GSC_T_UINTPTR);
if (0 == strcmp ("intmax_t", SCM_I_GSC_T_INTMAX))
pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF_INTMAX_T);
pf ("typedef long int scm_t_off;\n");
#endif
-#if USE_DLL_IMPORT
+ pf ("/* Define to 1 if the compiler supports the "
+ "`__thread' storage class. */\n");
+ if (SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS)
+ pf ("#define SCM_HAVE_THREAD_STORAGE_CLASS\n");
+ else
+ pf ("/* #undef SCM_HAVE_THREAD_STORAGE_CLASS */\n");
+
+#ifdef USE_DLL_IMPORT
pf ("\n");
pf ("/* Define some additional CPP macros on Win32 platforms. */\n");
pf ("# define __REGEX_IMPORT__ 1\n");
#define SCM_I_GSC_T_UINT64 @SCM_I_GSC_T_UINT64@
#define SCM_I_GSC_T_INTMAX @SCM_I_GSC_T_INTMAX@
#define SCM_I_GSC_T_UINTMAX @SCM_I_GSC_T_UINTMAX@
+#define SCM_I_GSC_T_INTPTR @SCM_I_GSC_T_INTPTR@
+#define SCM_I_GSC_T_UINTPTR @SCM_I_GSC_T_UINTPTR@
#define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@
#define SCM_I_GSC_USE_PTHREAD_THREADS @SCM_I_GSC_USE_PTHREAD_THREADS@
#define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@
#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT@
#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER@
+#define SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS @SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS@
#define SCM_I_GSC_HAVE_STRUCT_DIRENT64 @SCM_I_GSC_HAVE_STRUCT_DIRENT64@
/*
return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
}
-SCM_DEFINE (scm_array_p, "array?", 1, 0, 0,
- (SCM obj),
+SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
+ (SCM obj),
"Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
"not.")
-#define FUNC_NAME s_scm_array_p
+#define FUNC_NAME s_scm_array_p_2
{
return scm_from_bool (scm_is_array (obj));
}
#undef FUNC_NAME
+/* The array type predicate, with an extra argument kept for backward
+ compatibility. Note that we can't use `SCM_DEFINE' directly because there
+ would be an argument count mismatch that would be caught by
+ `snarf-check-and-output-texi.scm'. */
+SCM
+scm_array_p (SCM obj, SCM unused)
+{
+ return scm_array_p_2 (obj);
+}
+
int
scm_is_typed_array (SCM obj, SCM type)
{
/** Arrays */
SCM_API int scm_is_array (SCM obj);
-SCM_API SCM scm_array_p (SCM v);
+SCM_API SCM scm_array_p (SCM v, SCM unused);
+SCM_INTERNAL SCM scm_array_p_2 (SCM);
SCM_API int scm_is_typed_array (SCM obj, SCM type);
SCM_API SCM scm_typed_array_p (SCM v, SCM type);
ssize_t pos, i = 0;
scm_t_array_handle h;
scm_generalized_vector_get_handle (v, &h);
- // FIXME CHECKME
+ /* FIXME CHECKME */
for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd + 1);
i >= 0;
pos += h.dims[0].inc)
#include "libguile/keywords.h"
#include "libguile/macros.h"
#include "libguile/modules.h"
-#include "libguile/objects.h"
#include "libguile/ports.h"
#include "libguile/procprop.h"
+#include "libguile/programs.h"
#include "libguile/random.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/strports.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/goops.h"
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
+/* Port classes */
+#define SCM_IN_PCLASS_INDEX 0
+#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
+#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
+
/* this file is a mess. in theory, though, we shouldn't have many SCM references
-- most of the references should be to vars. */
static SCM var_slot_missing = SCM_BOOL_F;
static SCM var_compute_cpl = SCM_BOOL_F;
static SCM var_no_applicable_method = SCM_BOOL_F;
-static SCM var_memoize_method_x = SCM_BOOL_F;
static SCM var_change_class = SCM_BOOL_F;
SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
h1.
*/
-/* The following definition is located in libguile/objects.h:
-#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
-*/
-
#define TEST_CHANGE_CLASS(obj, class) \
{ \
class = SCM_CLASS_OF (obj); \
/* These variables are filled in by the object system when loaded. */
SCM scm_class_boolean, scm_class_char, scm_class_pair;
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
-SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
+SCM scm_class_primitive_generic;
SCM scm_class_vector, scm_class_null;
SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
SCM scm_class_unknown;
SCM scm_class_top, scm_class_object, scm_class_class;
SCM scm_class_applicable;
-SCM scm_class_entity, scm_class_entity_with_setter;
+SCM scm_class_applicable_struct, scm_class_applicable_struct_with_setter;
SCM scm_class_generic, scm_class_generic_with_setter;
SCM scm_class_accessor;
SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
SCM scm_class_extended_accessor;
SCM scm_class_method;
-SCM scm_class_simple_method, scm_class_accessor_method;
+SCM scm_class_accessor_method;
SCM scm_class_procedure_class;
-SCM scm_class_operator_class, scm_class_operator_with_setter_class;
-SCM scm_class_entity_class;
+SCM scm_class_applicable_struct_class;
SCM scm_class_number, scm_class_list;
SCM scm_class_keyword;
SCM scm_class_port, scm_class_input_output_port;
SCM scm_class_input_port, scm_class_output_port;
-SCM scm_class_foreign_class, scm_class_foreign_object;
SCM scm_class_foreign_slot;
SCM scm_class_self, scm_class_protected;
-SCM scm_class_opaque, scm_class_read_only;
-SCM scm_class_protected_opaque, scm_class_protected_read_only;
+SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
+SCM scm_class_protected_hidden, scm_class_protected_opaque, scm_class_protected_read_only;
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
+static SCM class_hashtable;
+static SCM class_fluid;
+static SCM class_dynamic_state;
+
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
offsets. See `SCM_IN_PCLASS_INDEX' et al. */
{
case scm_tcs_cons_nimcar:
return scm_class_pair;
- case scm_tcs_closures:
- return scm_class_procedure;
case scm_tc7_symbol:
return scm_class_symbol;
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_class_vector;
+ case scm_tc7_hashtable:
+ return class_hashtable;
+ case scm_tc7_fluid:
+ return class_fluid;
+ case scm_tc7_dynamic_state:
+ return class_dynamic_state;
case scm_tc7_string:
return scm_class_string;
case scm_tc7_number:
case scm_tc16_fraction:
return scm_class_fraction;
}
- case scm_tc7_asubr:
- case scm_tc7_subr_0:
- case scm_tc7_subr_1:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_3:
- case scm_tc7_subr_2:
- case scm_tc7_rpsubr:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_2o:
- case scm_tc7_lsubr_2:
- case scm_tc7_lsubr:
+ case scm_tc7_gsubr:
if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
return scm_class_primitive_generic;
else
return scm_class_procedure;
- case scm_tc7_gsubr:
case scm_tc7_program:
return scm_class_procedure;
- case scm_tc7_pws:
- return scm_class_procedure_with_setter;
case scm_tc7_smob:
{
return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
else
{
- SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
- SCM class = scm_make_extended_class_from_symbol (scm_is_true (name)
- ? name
- : scm_nullstr,
- SCM_I_OPERATORP (x));
+ SCM class, name;
+
+ name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
+ if (!scm_is_symbol (name))
+ name = scm_string_to_symbol (scm_nullstr);
+
+ class =
+ scm_make_extended_class_from_symbol (name,
+ SCM_STRUCT_APPLICABLE_P (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
case scm_tc3_struct:
case scm_tc3_tc7_1:
case scm_tc3_tc7_2:
- case scm_tc3_closure:
+ /* case scm_tc3_unused: */
/* Never reached */
break;
}
init = scm_get_keyword (k_init_value, options, 0);
if (init)
{
- init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- SCM_EOL,
- scm_list_2 (scm_sym_quote,
- init)),
- SCM_EOL);
+ init = scm_primitive_eval (scm_list_3 (scm_sym_lambda,
+ SCM_EOL,
+ scm_list_2 (scm_sym_quote,
+ init)));
}
else
init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
a = 'o';
else if (SCM_SUBCLASSP (type, scm_class_read_only))
a = 'r';
+ else if (SCM_SUBCLASSP (type, scm_class_hidden))
+ a = 'h';
else
a = 'w';
}
inconsistent:
SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
}
- SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
+ SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"")
#define FUNC_NAME s_scm_sys_inherit_magic_x
{
- SCM ls = dsupers;
- long flags = 0;
SCM_VALIDATE_INSTANCE (1, class);
- while (!scm_is_null (ls))
- {
- SCM_ASSERT (scm_is_pair (ls)
- && SCM_INSTANCEP (SCM_CAR (ls)),
- dsupers,
- SCM_ARG2,
- FUNC_NAME);
- flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
- ls = SCM_CDR (ls);
- }
- flags &= SCM_CLASSF_INHERIT;
- if (flags & SCM_CLASSF_ENTITY)
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity);
- else
- {
- long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
-#if 0
- /*
- * We could avoid calling scm_gc_malloc in the allocation code
- * (in which case the following two lines are needed). Instead
- * we make 0-slot instances non-light, so that the light case
- * can be handled without special cases.
- */
- if (n == 0)
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0);
-#endif
- if (n > 0 && !(flags & SCM_CLASSF_METACLASS))
- {
- /* NOTE: The following depends on scm_struct_i_size. */
- flags |= SCM_STRUCTF_LIGHT + n * sizeof (SCM); /* use light representation */
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
- }
- }
- SCM_SET_CLASS_FLAGS (class, flags);
+ scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
+ SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
prep_hashsets (class);
{
unsigned int i;
- for (i = 0; i < 7; ++i)
+ for (i = 0; i < 8; ++i)
SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate));
}
nfields = scm_from_int (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
- SCM_SET_SLOT (z, scm_si_name, name);
+ SCM_SET_SLOT (z, scm_vtable_index_name, name);
SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
SCM_SET_SLOT (z, scm_si_nfields, nfields);
SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
- SCM_SET_SLOT (z, scm_si_environment,
- scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
/* Add this class in the direct-subclasses slot of dsupers */
{
scm_si_direct_subclasses)));
}
- /* Support for the underlying structs: */
- SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class
- ? (SCM_CLASSF_GOOPS_OR_VALID
- | SCM_CLASSF_OPERATOR
- | SCM_CLASSF_ENTITY)
- : class == scm_class_operator_class
- ? SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_OPERATOR
- : SCM_CLASSF_GOOPS_OR_VALID));
return z;
}
scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
{
SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
- scm_sys_inherit_magic_x (z, dsupers);
scm_sys_prep_layout_x (z);
+ scm_sys_inherit_magic_x (z, dsupers);
return z;
}
/******************************************************************************/
SCM_SYMBOL (sym_layout, "layout");
-SCM_SYMBOL (sym_vcell, "vcell");
-SCM_SYMBOL (sym_vtable, "vtable");
+SCM_SYMBOL (sym_flags, "flags");
+SCM_SYMBOL (sym_self, "%self");
+SCM_SYMBOL (sym_instance_finalizer, "instance-finalizer");
+SCM_SYMBOL (sym_reserved_0, "%reserved-0");
+SCM_SYMBOL (sym_reserved_1, "%reserved-1");
SCM_SYMBOL (sym_print, "print");
SCM_SYMBOL (sym_procedure, "procedure");
SCM_SYMBOL (sym_setter, "setter");
SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
SCM_SYMBOL (sym_keyword_access, "keyword-access");
SCM_SYMBOL (sym_nfields, "nfields");
-SCM_SYMBOL (sym_environment, "environment");
static SCM
build_class_class_slots ()
{
+ /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
+ SCM_CLASS_CLASS_LAYOUT */
return scm_list_n (
scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
- scm_list_3 (sym_vtable, k_class, scm_class_self),
+ scm_list_3 (sym_flags, k_class, scm_class_hidden),
+ scm_list_3 (sym_self, k_class, scm_class_self),
+ scm_list_3 (sym_instance_finalizer, k_class, scm_class_hidden),
scm_list_1 (sym_print),
- scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque),
- scm_list_3 (sym_setter, k_class, scm_class_protected_opaque),
+ scm_list_3 (sym_name, k_class, scm_class_protected_hidden),
+ scm_list_3 (sym_reserved_0, k_class, scm_class_hidden),
+ scm_list_3 (sym_reserved_1, k_class, scm_class_hidden),
scm_list_1 (sym_redefined),
scm_list_3 (sym_h0, k_class, scm_class_int),
scm_list_3 (sym_h1, k_class, scm_class_int),
scm_list_3 (sym_h5, k_class, scm_class_int),
scm_list_3 (sym_h6, k_class, scm_class_int),
scm_list_3 (sym_h7, k_class, scm_class_int),
- scm_list_1 (sym_name),
scm_list_1 (sym_direct_supers),
scm_list_1 (sym_direct_slots),
scm_list_1 (sym_direct_subclasses),
scm_list_1 (sym_getters_n_setters),
scm_list_1 (sym_keyword_access),
scm_list_1 (sym_nfields),
- scm_list_1 (sym_environment),
SCM_UNDEFINED);
}
{
/* SCM slots_of_class = build_class_class_slots (); */
- /**** <scm_class_class> ****/
- SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
- + 2 * scm_vtable_offset_user);
+ /**** <class> ****/
+ SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM name = scm_from_locale_symbol ("<class>");
- scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
- SCM_INUM0,
- SCM_EOL));
+ scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
- SCM_SET_SLOT (scm_class_class, scm_si_name, name);
+ SCM_SET_SLOT (scm_class_class, scm_vtable_index_name, name);
SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
/* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
/* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
compute_getters_n_setters (slots_of_class)); */
SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
- SCM_SET_SLOT (scm_class_class, scm_si_environment,
- scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
prep_hashsets (scm_class_class);
DEFVAR(name, scm_class_class);
- /**** <scm_class_top> ****/
+ /**** <top> ****/
name = scm_from_locale_symbol ("<top>");
- scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
- name,
- SCM_EOL,
- SCM_EOL));
+ scm_class_top = scm_basic_make_class (scm_class_class, name,
+ SCM_EOL, SCM_EOL);
DEFVAR(name, scm_class_top);
- /**** <scm_class_object> ****/
+ /**** <object> ****/
name = scm_from_locale_symbol ("<object>");
- scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
- name,
- scm_list_1 (scm_class_top),
- SCM_EOL));
+ scm_class_object = scm_basic_make_class (scm_class_class, name,
+ scm_list_1 (scm_class_top), SCM_EOL);
DEFVAR (name, scm_class_object);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
- (SCM obj),
- "Return the environment of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_environment
-{
- SCM_VALIDATE_CLASS (1, obj);
- return scm_slot_ref(obj, sym_environment);
-}
-#undef FUNC_NAME
-
-
SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
(SCM obj),
"Return the name of the generic function @var{obj}.")
}
#undef FUNC_NAME
-SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
- (SCM obj),
- "Return the slot definition of the accessor @var{obj}.")
-#define FUNC_NAME s_scm_accessor_method_slot_definition
-{
- SCM_VALIDATE_ACCESSOR (1, obj);
- return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_sys_tag_body, "%tag-body", 1, 0, 0,
- (SCM body),
- "Internal GOOPS magic---don't use this function!")
-#define FUNC_NAME s_scm_sys_tag_body
-{
- return scm_cons (SCM_IM_LAMBDA, body);
-}
-#undef FUNC_NAME
-
/******************************************************************************
*
* S l o t a c c e s s
access bits for us. */
return scm_struct_ref (obj, access);
else
- {
- /* We must evaluate (apply (car access) (list obj))
- * where (car access) is known to be a closure of arity 1 */
- register SCM code, env;
-
- code = SCM_CAR (access);
- if (!SCM_CLOSUREP (code))
- return scm_call_1 (code, obj);
- env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
- scm_list_1 (obj),
- SCM_ENV (code));
- /* Evaluate the closure body */
- return scm_eval_body (SCM_CLOSURE_BODY (code), env);
- }
+ return scm_call_1 (SCM_CAR (access), obj);
}
#undef FUNC_NAME
/* obey permissions bits via going through struct-set! */
scm_struct_set_x (obj, access, value);
else
- {
- /* We must evaluate (apply (cadr l) (list obj value))
- * where (cadr l) is known to be a closure of arity 2 */
- register SCM code, env;
-
- code = SCM_CADR (access);
- if (!SCM_CLOSUREP (code))
- scm_call_2 (code, obj, value);
- else
- {
- env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
- scm_list_2 (obj, value),
- SCM_ENV (code));
- /* Evaluate the closure body */
- scm_eval_body (SCM_CLOSURE_BODY (code), env);
- }
- }
+ /* ((cadr l) obj value) */
+ scm_call_2 (SCM_CADR (access), obj, value);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static void clear_method_cache (SCM);
-static SCM
-wrap_init (SCM class, SCM *m, long n)
-{
- long i;
- scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
- SCM layout = SCM_PACK (slayout);
-
- /* Set all SCM-holding slots to unbound */
- for (i = 0; i < n; i++)
- if (scm_i_symbol_ref (layout, i*2) == 'p')
- m[i] = SCM_GOOPS_UNBOUND;
- else
- m[i] = 0;
-
- return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
- | scm_tc3_struct),
- (scm_t_bits) m, 0, 0);
-}
-
SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
(SCM class, SCM initargs),
"Create a new instance of class @var{class} and initialize it\n"
"from the arguments @var{initargs}.")
#define FUNC_NAME s_scm_sys_allocate_instance
{
- SCM *m;
+ SCM obj;
long n;
+ long i;
+ SCM layout;
SCM_VALIDATE_CLASS (1, class);
- /* Most instances */
- if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
- {
- n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
- return wrap_init (class, m, n);
- }
-
- /* Foreign objects */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
- return scm_make_foreign_object (class, initargs);
+ /* FIXME: duplicates some of scm_make_struct. */
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n);
+
+ layout = SCM_VTABLE_LAYOUT (class);
- /* Entities */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
+ /* Set all SCM-holding slots to unbound */
+ for (i = 0; i < n; i++)
{
- m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
- "entity struct");
- m[scm_struct_i_setter] = SCM_BOOL_F;
- m[scm_struct_i_procedure] = SCM_BOOL_F;
- /* Generic functions */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
- {
- SCM gf = wrap_init (class, m, n);
- clear_method_cache (gf);
- return gf;
- }
+ scm_t_wchar c = scm_i_symbol_ref (layout, i*2);
+ if (c == 'p')
+ SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND);
+ else if (c == 's')
+ SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj);
else
- return wrap_init (class, m, n);
+ SCM_STRUCT_DATA (obj)[i] = 0;
}
- /* Class objects */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
- {
- long i;
-
- /* allocate class object */
- SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
-
- SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND);
- for (i = scm_si_goops_fields; i < n; i++)
- SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
-
- if (SCM_SUBCLASSP (class, scm_class_entity_class))
- SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
- else if (SCM_SUBCLASSP (class, scm_class_operator_class))
- SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR);
-
- return z;
- }
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
+ clear_method_cache (obj);
- /* Non-light instances */
- {
- m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
- return wrap_init (class, m, n);
- }
+ return obj;
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_sys_set_object_setter_x
{
SCM_ASSERT (SCM_STRUCTP (obj)
- && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
- || SCM_I_ENTITYP (obj)),
+ && (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC),
obj,
SCM_ARG1,
FUNC_NAME);
- if (SCM_I_ENTITYP (obj))
- SCM_SET_ENTITY_SETTER (obj, setter);
- else
- SCM_OPERATOR_CLASS (obj)->setter = setter;
+ SCM_SET_GENERIC_SETTER (obj, setter);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
*/
SCM_CRITICAL_SECTION_START;
{
- SCM car = SCM_CAR (old);
- SCM cdr = SCM_CDR (old);
- SCM_SETCAR (old, SCM_CAR (new));
- SCM_SETCDR (old, SCM_CDR (new));
- SCM_SETCAR (new, car);
- SCM_SETCDR (new, cdr);
+ scm_t_bits word0, word1;
+ word0 = SCM_CELL_WORD_0 (old);
+ word1 = SCM_CELL_WORD_1 (old);
+ SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
+ SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
+ SCM_SET_CELL_WORD_0 (new, word0);
+ SCM_SET_CELL_WORD_1 (new, word1);
}
SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
SCM_CRITICAL_SECTION_START;
{
- SCM car = SCM_CAR (old);
- SCM cdr = SCM_CDR (old);
- SCM_SETCAR (old, SCM_CAR (new));
- SCM_SETCDR (old, SCM_CDR (new));
- SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
- SCM_SETCAR (new, car);
- SCM_SETCDR (new, cdr);
- SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
+ scm_t_bits word0, word1;
+ word0 = SCM_CELL_WORD_0 (old);
+ word1 = SCM_CELL_WORD_1 (old);
+ SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
+ SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
+ SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
+ SCM_SET_CELL_WORD_0 (new, word0);
+ SCM_SET_CELL_WORD_1 (new, word1);
+ SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
}
SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
SCM_KEYWORD (k_name, "name");
-SCM_SYMBOL (sym_no_method, "no-method");
+SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
-static SCM list_of_no_method;
-SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+SCM
+scm_apply_generic (SCM gf, SCM args)
+{
+ return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL);
+}
+SCM
+scm_call_generic_0 (SCM gf)
+{
+ return scm_call_0 (SCM_STRUCT_PROCEDURE (gf));
+}
SCM
-scm_make_method_cache (SCM gf)
+scm_call_generic_1 (SCM gf, SCM a1)
+{
+ return scm_call_1 (SCM_STRUCT_PROCEDURE (gf), a1);
+}
+
+SCM
+scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
+{
+ return scm_call_2 (SCM_STRUCT_PROCEDURE (gf), a1, a2);
+}
+
+SCM
+scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
+{
+ return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
+}
+
+SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
+static SCM
+make_dispatch_procedure (SCM gf)
{
- return scm_list_5 (SCM_IM_DISPATCH,
- scm_sym_args,
- scm_from_int (1),
- scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
- list_of_no_method),
- gf);
+ static SCM var = SCM_BOOL_F;
+ if (var == SCM_BOOL_F)
+ var = scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
+ sym_delayed_compile);
+ return scm_call_1 (SCM_VARIABLE_REF (var), gf);
}
static void
clear_method_cache (SCM gf)
{
- SCM cache = scm_make_method_cache (gf);
- SCM_SET_ENTITY_PROCEDURE (gf, cache);
- SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F);
+ SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf, make_dispatch_procedure (gf));
+ SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf);
}
SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
"")
#define FUNC_NAME s_scm_sys_invalidate_method_cache_x
{
- SCM used_by;
SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
- used_by = SCM_SLOT (gf, scm_si_used_by);
- if (scm_is_true (used_by))
- {
- SCM methods = SCM_SLOT (gf, scm_si_methods);
- for (; scm_is_pair (used_by); used_by = SCM_CDR (used_by))
- scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
- clear_method_cache (gf);
- for (; scm_is_pair (methods); methods = SCM_CDR (methods))
- SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
- }
- {
- SCM n = SCM_SLOT (gf, scm_si_n_specialized);
- /* The sign of n is a flag indicating rest args. */
- SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), n);
- }
+ clear_method_cache (gf);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
}
#undef FUNC_NAME
+SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
+ (SCM subr, SCM generic),
+ "")
+#define FUNC_NAME s_scm_set_primitive_generic_x
+{
+ SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
+ subr, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
+ *SCM_SUBR_GENERIC (subr) = generic;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
(SCM subr),
"")
SCM extension;
} t_extension;
-static t_extension *extensions = 0;
-SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
+/* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
+ objects. */
+static const char extension_gc_hint[] = "GOOPS extension";
+
+static t_extension *extensions = 0;
void
scm_c_extend_primitive_generic (SCM extended, SCM extension)
}
else
{
- t_extension *e = scm_malloc (sizeof (t_extension));
+ t_extension *e = scm_gc_malloc (sizeof (t_extension),
+ extension_gc_hint);
t_extension **loc = &extensions;
/* Make sure that extensions are placed before their own
* extensions in the extensions list. O(N^2) algorithm, but
t_extension *e = extensions;
scm_c_extend_primitive_generic (e->extended, e->extension);
extensions = e->next;
- free (e);
}
}
for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
{
fl = SPEC_OF (SCM_CAR (l));
- /* Only accept accessors which match exactly in first arg. */
- if (SCM_ACCESSORP (SCM_CAR (l))
- && (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
- continue;
for (i = 0; ; i++, fl = SCM_CDR (fl))
{
if (SCM_INSTANCEP (fl)
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
-static void
-lock_cache_mutex (void *m)
-{
- SCM mutex = SCM_PACK ((scm_t_bits) m);
- scm_lock_mutex (mutex);
-}
-
-static void
-unlock_cache_mutex (void *m)
-{
- SCM mutex = SCM_PACK ((scm_t_bits) m);
- scm_unlock_mutex (mutex);
-}
-
-static SCM
-call_memoize_method (void *a)
-{
- SCM args = SCM_PACK ((scm_t_bits) a);
- SCM gf = SCM_CAR (args);
- SCM x = SCM_CADR (args);
- /* First check if another thread has inserted a method between
- * the cache miss and locking the mutex.
- */
- SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
- if (scm_is_true (cmethod))
- return cmethod;
-
- if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x)))
- var_memoize_method_x =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_memoize_method_x));
-
- return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR (args), x);
-}
-
-SCM
-scm_memoize_method (SCM x, SCM args)
-{
- SCM gf = SCM_CAR (scm_last_pair (x));
- return scm_internal_dynamic_wind (
- lock_cache_mutex,
- call_memoize_method,
- unlock_cache_mutex,
- (void *) SCM_UNPACK (scm_cons2 (gf, x, args)),
- (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex)));
-}
-
/******************************************************************************
*
* A simple make (which will be redefined later in Scheme)
if (class == scm_class_generic || class == scm_class_accessor)
{
z = scm_make_struct (class, SCM_INUM0,
- scm_list_5 (SCM_EOL,
+ scm_list_4 (SCM_BOOL_F,
+ SCM_EOL,
SCM_INUM0,
- SCM_BOOL_F,
- scm_make_mutex (),
SCM_EOL));
scm_set_procedure_property_x (z, scm_sym_name,
scm_get_keyword (k_name,
z = scm_sys_allocate_instance (class, args);
if (class == scm_class_method
- || class == scm_class_simple_method
|| class == scm_class_accessor_method)
{
SCM_SET_SLOT (z, scm_si_generic_function,
len - 1,
SCM_BOOL_F,
FUNC_NAME));
- SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
SCM_SET_SLOT (z, scm_si_formals,
scm_i_get_keyword (k_formals,
args,
else
{
/* In all the others case, make a new class .... No instance here */
- SCM_SET_SLOT (z, scm_si_name,
+ SCM_SET_SLOT (z, scm_vtable_index_name,
scm_i_get_keyword (k_name,
args,
len - 1,
{
SCM tmp = scm_from_locale_symbol (name);
- *var = scm_permanent_object (scm_basic_make_class (meta,
- tmp,
- scm_is_pair (super)
- ? super
- : scm_list_1 (super),
- slots));
+ *var = scm_basic_make_class (meta, tmp,
+ scm_is_pair (super) ? super : scm_list_1 (super),
+ slots);
DEFVAR(tmp, *var);
}
SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
scm_from_locale_symbol ("specializers"),
sym_procedure,
- scm_from_locale_symbol ("code-table"),
scm_from_locale_symbol ("formals"),
scm_from_locale_symbol ("body"),
scm_from_locale_symbol ("make-procedure"),
SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
k_init_keyword,
k_slot_definition));
- SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex"));
- SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- SCM_EOL,
- mutex_slot),
- SCM_EOL);
- SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"),
+ SCM gf_slots = scm_list_4 (scm_from_locale_symbol ("methods"),
scm_list_3 (scm_from_locale_symbol ("n-specialized"),
k_init_value,
SCM_INUM0),
- scm_list_3 (scm_from_locale_symbol ("used-by"),
- k_init_value,
- SCM_BOOL_F),
- scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
- k_init_thunk,
- mutex_closure),
scm_list_3 (scm_from_locale_symbol ("extended-by"),
k_init_value,
- SCM_EOL));
+ SCM_EOL),
+ scm_from_locale_symbol ("effective-methods"));
+ SCM setter_slots = scm_list_1 (sym_setter);
SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
k_init_value,
SCM_EOL));
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_protected, "<protected-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
+ make_stdcls (&scm_class_hidden, "<hidden-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_opaque, "<opaque-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_read_only, "<read-only-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_self, "<self-slot>",
- scm_class_class,
- scm_class_read_only,
- SCM_EOL);
+ scm_class_class, scm_class_read_only, SCM_EOL);
make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
scm_class_class,
scm_list_2 (scm_class_protected, scm_class_opaque),
SCM_EOL);
+ make_stdcls (&scm_class_protected_hidden, "<protected-hidden-slot>",
+ scm_class_class,
+ scm_list_2 (scm_class_protected, scm_class_hidden),
+ SCM_EOL);
make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
scm_class_class,
scm_list_2 (scm_class_protected, scm_class_read_only),
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
compute_getters_n_setters (slots));
- make_stdcls (&scm_class_foreign_class, "<foreign-class>",
- scm_class_class, scm_class_class,
- scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
- k_class,
- scm_class_opaque),
- scm_list_3 (scm_from_locale_symbol ("destructor"),
- k_class,
- scm_class_opaque)));
- make_stdcls (&scm_class_foreign_object, "<foreign-object>",
- scm_class_foreign_class, scm_class_object, SCM_EOL);
- SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
-
/* scm_class_generic functions classes */
make_stdcls (&scm_class_procedure_class, "<procedure-class>",
scm_class_class, scm_class_class, SCM_EOL);
- make_stdcls (&scm_class_entity_class, "<entity-class>",
- scm_class_class, scm_class_procedure_class, SCM_EOL);
- make_stdcls (&scm_class_operator_class, "<operator-class>",
+ make_stdcls (&scm_class_applicable_struct_class, "<applicable-struct-class>",
scm_class_class, scm_class_procedure_class, SCM_EOL);
- make_stdcls (&scm_class_operator_with_setter_class,
- "<operator-with-setter-class>",
- scm_class_class, scm_class_operator_class, SCM_EOL);
+ SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
make_stdcls (&scm_class_method, "<method>",
scm_class_class, scm_class_object, method_slots);
- make_stdcls (&scm_class_simple_method, "<simple-method>",
- scm_class_class, scm_class_method, SCM_EOL);
- SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
make_stdcls (&scm_class_accessor_method, "<accessor-method>",
- scm_class_class, scm_class_simple_method, amethod_slots);
- SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
+ scm_class_class, scm_class_method, amethod_slots);
make_stdcls (&scm_class_applicable, "<applicable>",
scm_class_class, scm_class_top, SCM_EOL);
- make_stdcls (&scm_class_entity, "<entity>",
- scm_class_entity_class,
+ make_stdcls (&scm_class_applicable_struct, "<applicable-struct>",
+ scm_class_applicable_struct_class,
scm_list_2 (scm_class_object, scm_class_applicable),
- SCM_EOL);
- make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
- scm_class_entity_class, scm_class_entity, SCM_EOL);
+ scm_list_1 (sym_procedure));
make_stdcls (&scm_class_generic, "<generic>",
- scm_class_entity_class, scm_class_entity, gf_slots);
+ scm_class_applicable_struct_class, scm_class_applicable_struct, gf_slots);
SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic, "<extended-generic>",
- scm_class_entity_class, scm_class_generic, egf_slots);
+ scm_class_applicable_struct_class, scm_class_generic, egf_slots);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
- scm_class_entity_class,
- scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
- SCM_EOL);
+ scm_class_applicable_struct_class, scm_class_generic, setter_slots);
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_accessor, "<accessor>",
- scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
+ scm_class_applicable_struct_class, scm_class_generic_with_setter, SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
- scm_class_entity_class,
+ scm_class_applicable_struct_class,
scm_list_2 (scm_class_generic_with_setter,
scm_class_extended_generic),
SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
- scm_class_entity_class,
+ scm_class_applicable_struct_class,
scm_list_2 (scm_class_accessor,
scm_class_extended_generic_with_setter),
SCM_EOL);
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_vector, "<vector>",
scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_hashtable, "<hashtable>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_fluid, "<fluid>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_dynamic_state, "<dynamic-state>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_number, "<number>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_complex, "<complex>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_procedure, "<procedure>",
scm_class_procedure_class, scm_class_applicable, SCM_EOL);
- make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
- scm_class_procedure_class, scm_class_procedure, SCM_EOL);
make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
scm_class_procedure_class, scm_class_procedure, SCM_EOL);
make_stdcls (&scm_class_port, "<port>",
else
name = SCM_GOOPS_UNBOUND;
- class = scm_permanent_object (scm_basic_make_class (applicablep
- ? scm_class_procedure_class
- : scm_class_class,
- name,
- supers,
- SCM_EOL));
+ class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
+ name, supers, SCM_EOL);
/* Only define name if doesn't already exist. */
if (!SCM_GOOPS_UNBOUNDP (name)
else
name = SCM_GOOPS_UNBOUND;
- class = scm_permanent_object (scm_basic_make_class (applicablep
- ? scm_class_procedure_class
- : scm_class_class,
- name,
- supers,
- SCM_EOL));
+ class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
+ name, supers, SCM_EOL);
/* Only define name if doesn't already exist. */
if (!SCM_GOOPS_UNBOUNDP (name)
SCM sym = SCM_STRUCT_TABLE_NAME (data);
if (scm_is_true (sym))
{
- int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR;
+ int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE;
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class_from_symbol (sym, applicablep));
}
-SCM
-scm_make_foreign_object (SCM class, SCM initargs)
-#define FUNC_NAME s_scm_make
-{
- void * (*constructor) (SCM)
- = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor);
- if (constructor == 0)
- SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
- return scm_wrap_object (class, constructor (initargs));
-}
-#undef FUNC_NAME
-
-
-static size_t
-scm_free_foreign_object (SCM *class, SCM *data)
-{
- size_t (*destructor) (void *)
- = (size_t (*) (void *)) class[scm_si_destructor];
- return destructor (data);
-}
-
-SCM
-scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
- void * (*constructor) (SCM initargs),
- size_t (*destructor) (void *))
-{
- SCM name, class;
- name = scm_from_locale_symbol (s_name);
- if (scm_is_null (supers))
- supers = scm_list_1 (scm_class_foreign_object);
- class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
- scm_sys_inherit_magic_x (class, supers);
-
- if (destructor != 0)
- {
- SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
- SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
- }
- else if (size > 0)
- {
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
- SCM_SET_CLASS_INSTANCE_SIZE (class, size);
- }
-
- SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
- SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
-
- return class;
-}
-
SCM_SYMBOL (sym_o, "o");
SCM_SYMBOL (sym_x, "x");
SCM_KEYWORD (k_accessor, "accessor");
SCM_KEYWORD (k_getter, "getter");
-static SCM
-default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
-{
- scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
- return 0;
-}
-
-void
-scm_add_slot (SCM class, char *slot_name, SCM slot_class,
- SCM (*getter) (SCM obj),
- SCM (*setter) (SCM obj, SCM x),
- char *accessor_name)
-{
- {
- SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter);
- SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2,
- setter ? setter : default_setter);
-
- /* Dirk:FIXME:: The following two expressions make use of the fact that
- * the memoizer will accept a subr-object in the place of a function.
- * This is not guaranteed to stay this way. */
- SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- scm_list_1 (sym_o),
- scm_list_2 (get, sym_o)),
- SCM_EOL);
- SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- scm_list_2 (sym_o, sym_x),
- scm_list_3 (set, sym_o, sym_x)),
- SCM_EOL);
-
- {
- SCM name = scm_from_locale_symbol (slot_name);
- SCM aname = scm_from_locale_symbol (accessor_name);
- SCM gf = scm_ensure_accessor (aname);
- SCM slot = scm_list_5 (name,
- k_class,
- slot_class,
- setter ? k_accessor : k_getter,
- gf);
- scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
- k_specializers,
- scm_list_1 (class),
- k_procedure,
- getm)));
- scm_add_method (scm_setter (gf),
- scm_make (scm_list_5 (scm_class_accessor_method,
- k_specializers,
- scm_list_2 (class, scm_class_top),
- k_procedure,
- setm)));
- DEFVAR (aname, gf);
-
- SCM_SET_SLOT (class, scm_si_slots,
- scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
- scm_list_1 (slot))));
- {
- SCM n = SCM_SLOT (class, scm_si_nfields);
- SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
- SCM_UNDEFINED);
- SCM_SET_SLOT (class, scm_si_getters_n_setters,
- scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
- scm_list_1 (gns))));
- SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1)));
- }
- }
- }
-}
-
-SCM
-scm_wrap_object (SCM class, void *data)
-{
- return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
- (scm_t_bits) data,
- 0, 0);
-}
-
-SCM scm_components;
-
-SCM
-scm_wrap_component (SCM class, SCM container, void *data)
-{
- SCM obj = scm_wrap_object (class, data);
- SCM handle = scm_hash_fn_create_handle_x (scm_components,
- obj,
- SCM_BOOL_F,
- scm_struct_ihashq,
- scm_sloppy_assq,
- 0);
- SCM_SETCDR (handle, container);
- return obj;
-}
-
SCM
scm_ensure_accessor (SCM name)
{
{
goops_loaded_p = 1;
var_compute_applicable_methods =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_compute_applicable_methods));
+ scm_module_variable (scm_module_goops, sym_compute_applicable_methods);
var_slot_unbound =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_slot_unbound));
+ scm_module_variable (scm_module_goops, sym_slot_unbound);
var_slot_missing =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_slot_missing));
+ scm_module_variable (scm_module_goops, sym_slot_missing);
var_compute_cpl =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_compute_cpl));
+ scm_module_variable (scm_module_goops, sym_compute_cpl);
var_no_applicable_method =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_no_applicable_method));
+ scm_module_variable (scm_module_goops, sym_no_applicable_method);
var_change_class =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_change_class));
+ scm_module_variable (scm_module_goops, sym_change_class);
setup_extended_primitive_generics ();
return SCM_UNSPECIFIED;
}
{
scm_module_goops = scm_current_module ();
- /* Not really necessary right now, but who knows...
- */
- scm_permanent_object (scm_module_goops);
-
- scm_components = scm_permanent_object (scm_make_weak_key_hash_table
- (scm_from_int (37)));
-
goops_rstate = scm_c_make_rstate ("GOOPS", 5);
#include "libguile/goops.x"
- list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
-
hell = scm_calloc (hell_size * sizeof (*hell));
- hell_mutex = scm_permanent_object (scm_make_mutex ());
+ hell_mutex = scm_make_mutex ();
create_basic_classes ();
create_standard_classes ();
{
SCM name = scm_from_locale_symbol ("no-applicable-method");
- scm_no_applicable_method
- = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic,
- k_name,
- name)));
+ scm_no_applicable_method =
+ scm_make (scm_list_3 (scm_class_generic, k_name, name));
DEFVAR (name, scm_no_applicable_method);
}
#include "libguile/validate.h"
+/* {Class flags}
+ *
+ * These are used for efficient identification of instances of a
+ * certain class or its subclasses when traversal of the inheritance
+ * graph would be too costly.
+ */
+#define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0
+#define SCM_VTABLE_FLAG_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_1
+#define SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_2
+
+#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
+#define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class))
+#define SCM_OBJ_CLASS_FLAGS(obj) (SCM_STRUCT_VTABLE_FLAGS (obj))
+#define SCM_SET_CLASS_FLAGS(c, f) (SCM_SET_VTABLE_FLAGS (c, f))
+#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLEAR_VTABLE_FLAGS (c, f))
+
+#define SCM_CLASSF_METACLASS (SCM_VTABLE_FLAG_GOOPS_CLASS|SCM_VTABLE_FLAG_VTABLE)
+#define SCM_CLASSF_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC
+#define SCM_CLASSF_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_VALID
+#define SCM_CLASSF_GOOPS SCM_VTABLE_FLAG_GOOPS_CLASS
+#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
+
/*
* scm_class_class
*/
-#define SCM_CLASS_CLASS_LAYOUT "prsrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw"
-
-#define scm_si_layout 0 /* the struct layout */
-#define scm_si_vtable 1
-#define scm_si_print 2 /* the struct print closure */
-#define scm_si_proc 3
-#define scm_si_setter 4
-
-#define scm_si_goops_fields 5
-
-/* Defined in libguile/objects.h:
-#define scm_si_redefined 5 The class to which class was redefined.
-#define scm_si_hashsets 6
-*/
-#define scm_si_name 14 /* a symbol */
-#define scm_si_direct_supers 15 /* (class ...) */
-#define scm_si_direct_slots 16 /* ((name . options) ...) */
-#define scm_si_direct_subclasses 17 /* (class ...) */
-#define scm_si_direct_methods 18 /* (methods ...) */
-#define scm_si_cpl 19 /* (class ...) */
-#define scm_si_slotdef_class 20
-#define scm_si_slots 21 /* ((name . options) ...) */
-#define scm_si_name_access 22
-#define scm_si_keyword_access 23
-#define scm_si_nfields 24 /* an integer */
-#define scm_si_environment 25 /* The environment in which class is built */
-#define SCM_N_CLASS_SLOTS 26
+/* see also, SCM_VTABLE_BASE_LAYOUT, and build_class_class_slots */
+#define SCM_CLASS_CLASS_LAYOUT \
+ "pw" /* redefined */ \
+ "uw" /* h0 */ \
+ "uw" /* h1 */ \
+ "uw" /* h2 */ \
+ "uw" /* h3 */ \
+ "uw" /* h4 */ \
+ "uw" /* h5 */ \
+ "uw" /* h6 */ \
+ "uw" /* h7 */ \
+ "pw" /* direct supers */ \
+ "pw" /* direct slots */ \
+ "pw" /* direct subclasses */ \
+ "pw" /* direct methods */ \
+ "pw" /* cpl */ \
+ "pw" /* default-slot-definition-class */ \
+ "pw" /* slots */ \
+ "pw" /* getters-n-setters */ \
+ "pw" /* keyword access */ \
+ "pw" /* nfields */
+
+#define scm_si_redefined (scm_vtable_offset_user + 0)
+#define scm_si_h0 (scm_vtable_offset_user + 1)
+#define scm_si_hashsets scm_si_h0
+#define scm_si_h1 (scm_vtable_offset_user + 2)
+#define scm_si_h2 (scm_vtable_offset_user + 3)
+#define scm_si_h3 (scm_vtable_offset_user + 4)
+#define scm_si_h4 (scm_vtable_offset_user + 5)
+#define scm_si_h5 (scm_vtable_offset_user + 6)
+#define scm_si_h6 (scm_vtable_offset_user + 7)
+#define scm_si_h7 (scm_vtable_offset_user + 8)
+#define scm_si_direct_supers (scm_vtable_offset_user + 9) /* (class ...) */
+#define scm_si_direct_slots (scm_vtable_offset_user + 10) /* ((name . options) ...) */
+#define scm_si_direct_subclasses (scm_vtable_offset_user + 11) /* (class ...) */
+#define scm_si_direct_methods (scm_vtable_offset_user + 12) /* (methods ...) */
+#define scm_si_cpl (scm_vtable_offset_user + 13) /* (class ...) */
+#define scm_si_slotdef_class (scm_vtable_offset_user + 14)
+#define scm_si_slots (scm_vtable_offset_user + 15) /* ((name . options) ...) */
+#define scm_si_name_access (scm_vtable_offset_user + 16)
+#define scm_si_getters_n_setters scm_si_name_access
+#define scm_si_keyword_access (scm_vtable_offset_user + 17)
+#define scm_si_nfields (scm_vtable_offset_user + 18) /* an integer */
+#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 19)
typedef struct scm_t_method {
SCM generic_function;
#define SCM_METHOD(obj) ((scm_t_method *) SCM_STRUCT_DATA (obj))
-#define SCM_CLASSF_SIMPLE_METHOD (0x004 << 20)
-#define SCM_CLASSF_ACCESSOR_METHOD (0x008 << 20)
-
-/* Defined in libguile/objects.c */
-/* #define SCM_CLASSF_PURE_GENERIC (0x010 << 20) */
-
-#define SCM_CLASSF_FOREIGN (0x020 << 20)
-#define SCM_CLASSF_METACLASS (0x040 << 20)
-
-/* Defined in libguile/objects.c */
-/* #define SCM_CLASSF_GOOPS_VALID (0x080 << 20) */
-/* #define SCM_CLASSF_GOOPS (0x100 << 20) */
-#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
-
-#define SCM_CLASSF_INHERIT (~(SCM_CLASSF_PURE_GENERIC \
- | SCM_CLASSF_SIMPLE_METHOD \
- | SCM_CLASSF_ACCESSOR_METHOD \
- | SCM_STRUCTF_LIGHT) \
- & SCM_CLASSF_MASK)
-
+#define SCM_OBJ_CLASS_REDEF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x) [scm_si_redefined]))
#define SCM_INST(x) SCM_STRUCT_DATA (x)
-/* Also defined in libguile/objects.c */
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_ACCESSORS_OF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters]))
(SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_PURE_GENERIC))
#define SCM_VALIDATE_PUREGENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, PUREGENERICP, "pure generic function")
-#define SCM_ACCESSORP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_ACCESSOR_METHOD))
-#define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, ACCESSORP, "accessor")
-
-#define SCM_SLOT(x, i) (SCM_PACK (SCM_INST (x) [i]))
-#define SCM_SET_SLOT(x, i, v) (SCM_INST (x) [i] = SCM_UNPACK (v))
+#define SCM_SLOT(x, i) (SCM_STRUCT_SLOT_REF (x, i))
+#define SCM_SET_SLOT(x, i, v) (SCM_STRUCT_SLOT_SET (x, i, v))
#define SCM_INSTANCE_HASH(c, i) (SCM_INST (c) [scm_si_hashsets + (i)])
#define SCM_SET_HASHSET(c, i, h) (SCM_INST (c) [scm_si_hashsets + (i)] = (h))
(SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_method))
#define SCM_VALIDATE_METHOD(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, METHODP, "method")
-#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C)
-#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X)
+#define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
-#define SCM_INITIAL_MCACHE_SIZE 1
+#define SCM_SET_GENERIC_DISPATCH_PROCEDURE(G,C) (SCM_STRUCT_SLOT_SET (G, scm_si_dispatch_procedure, (C)))
+#define SCM_CLEAR_GENERIC_EFFECTIVE_METHODS(G) (SCM_STRUCT_SLOT_SET (G, scm_si_effective_methods, SCM_EOL));
-#define scm_si_getters_n_setters scm_si_name_access
-
-#define scm_si_constructor SCM_N_CLASS_SLOTS
-#define scm_si_destructor SCM_N_CLASS_SLOTS + 1
+#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_si_generic_setter]))
+#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) [scm_si_generic_setter] = SCM_UNPACK (C))
-#define scm_si_methods 0 /* offset of methods slot in a <generic> */
-#define scm_si_n_specialized 1
-#define scm_si_used_by 2
-#define scm_si_cache_mutex 3
+#define scm_si_dispatch_procedure scm_applicable_struct_index_procedure /* 0 */
+#define scm_si_methods 1
+#define scm_si_n_specialized 2
+#define scm_si_extended_by 3
+#define scm_si_effective_methods 4
+#define scm_si_generic_setter 5
#define scm_si_generic_function 0 /* offset of gf slot in a <method> */
#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
#define scm_si_procedure 2 /* offset of proc. slot in a <method> */
-#define scm_si_code_table 3 /* offset of code. slot in a <method> */
-#define scm_si_formals 4 /* offset of form. slot in a <method> */
-#define scm_si_body 5 /* offset of body slot in a <method> */
-#define scm_si_make_procedure 6 /* offset of makep.slot in a <method> */
+#define scm_si_formals 3 /* offset of form. slot in a <method> */
+#define scm_si_body 4 /* offset of body slot in a <method> */
+#define scm_si_make_procedure 5 /* offset of makep.slot in a <method> */
/* C interface */
SCM_API SCM scm_class_boolean;
SCM_API SCM scm_class_procedure;
SCM_API SCM scm_class_string;
SCM_API SCM scm_class_symbol;
-SCM_API SCM scm_class_procedure_with_setter;
SCM_API SCM scm_class_primitive_generic;
-SCM_API SCM scm_class_vector, scm_class_null;
+SCM_API SCM scm_class_vector;
+SCM_API SCM scm_class_null;
SCM_API SCM scm_class_real;
SCM_API SCM scm_class_complex;
SCM_API SCM scm_class_integer;
SCM_API SCM scm_class_object;
SCM_API SCM scm_class_class;
SCM_API SCM scm_class_applicable;
-SCM_API SCM scm_class_entity;
-SCM_API SCM scm_class_entity_with_setter;
+SCM_API SCM scm_class_applicable_struct;
+SCM_API SCM scm_class_applicable_struct_with_setter;
SCM_API SCM scm_class_generic;
SCM_API SCM scm_class_generic_with_setter;
SCM_API SCM scm_class_accessor;
SCM_API SCM scm_class_extended_generic_with_setter;
SCM_API SCM scm_class_extended_accessor;
SCM_API SCM scm_class_method;
-SCM_API SCM scm_class_simple_method;
SCM_API SCM scm_class_accessor_method;
SCM_API SCM scm_class_procedure_class;
-SCM_API SCM scm_class_operator_class;
-SCM_API SCM scm_class_operator_with_setter_class;
-SCM_API SCM scm_class_entity_class;
+SCM_API SCM scm_class_applicable_struct_class;
SCM_API SCM scm_class_number;
SCM_API SCM scm_class_list;
SCM_API SCM scm_class_keyword;
SCM_API SCM scm_class_input_output_port;
SCM_API SCM scm_class_input_port;
SCM_API SCM scm_class_output_port;
-SCM_API SCM scm_class_foreign_class;
-SCM_API SCM scm_class_foreign_object;
SCM_API SCM scm_class_foreign_slot;
SCM_API SCM scm_class_self;
SCM_API SCM scm_class_protected;
+SCM_API SCM scm_class_hidden;
SCM_API SCM scm_class_opaque;
SCM_API SCM scm_class_read_only;
+SCM_API SCM scm_class_protected_hidden;
SCM_API SCM scm_class_protected_opaque;
SCM_API SCM scm_class_protected_read_only;
SCM_API SCM scm_class_scm;
SCM_API char *scm_c_oldfmt0 (char *);
SCM_API char *scm_c_oldfmt (char *, int n);
SCM_API void scm_load_goops (void);
-SCM_API SCM scm_make_foreign_object (SCM cls, SCM initargs);
-SCM_API SCM scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
- void * (*constructor) (SCM initargs),
- size_t (*destructor) (void *));
-SCM_API void scm_add_slot (SCM c, char *slot, SCM slot_class,
- SCM (*getter) (SCM obj),
- SCM (*setter) (SCM obj, SCM x),
- char *accessor_name);
-SCM_API SCM scm_wrap_object (SCM c, void *);
-SCM_API SCM scm_wrap_component (SCM c, SCM obj, void *);
+SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep);
+SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
SCM_API SCM scm_ensure_accessor (SCM name);
SCM_API void scm_add_method (SCM gf, SCM m);
SCM_API SCM scm_class_of (SCM obj);
#endif
SCM_API SCM scm_sys_compute_slots (SCM c);
+SCM_INTERNAL void scm_i_inherit_applicable (SCM c);
SCM_INTERNAL SCM scm_i_get_keyword (SCM key, SCM l, long len,
SCM default_value, const char *subr);
SCM_API SCM scm_get_keyword (SCM key, SCM l, SCM default_value);
SCM_API SCM scm_class_direct_methods (SCM obj);
SCM_API SCM scm_class_precedence_list (SCM obj);
SCM_API SCM scm_class_slots (SCM obj);
-SCM_API SCM scm_class_environment (SCM obj);
SCM_API SCM scm_generic_function_name (SCM obj);
SCM_API SCM scm_generic_function_methods (SCM obj);
SCM_API SCM scm_method_generic_function (SCM obj);
SCM_API SCM scm_method_specializers (SCM obj);
SCM_API SCM scm_method_procedure (SCM obj);
-SCM_API SCM scm_accessor_method_slot_definition (SCM obj);
-SCM_API SCM scm_sys_tag_body (SCM body);
SCM_API SCM scm_sys_fast_slot_ref (SCM obj, SCM index);
SCM_API SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value);
SCM_API SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name);
SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst);
SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls);
SCM_API SCM scm_sys_invalidate_class (SCM cls);
-SCM_API SCM scm_make_method_cache (SCM gf);
SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf);
SCM_API SCM scm_generic_capability_p (SCM proc);
SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
+SCM_INTERNAL SCM scm_set_primitive_generic_x (SCM subr, SCM generic);
SCM_API SCM scm_primitive_generic_generic (SCM subr);
SCM_API void scm_c_extend_primitive_generic (SCM subr, SCM extension);
SCM_API SCM stklos_version (void);
SCM_API SCM scm_make (SCM args);
SCM_API SCM scm_find_method (SCM args);
SCM_API SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs);
+SCM_API void scm_change_object_class (SCM, SCM, SCM);
+/* The following are declared in __scm.h
+SCM_API SCM scm_call_generic_0 (SCM gf);
+SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
+SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
+SCM_API SCM scm_apply_generic (SCM gf, SCM args);
+*/
+SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
+
SCM_INTERNAL SCM scm_init_goops_builtins (void);
SCM_INTERNAL void scm_init_goops (void);
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-#define SCM_INST_TYPE(x) SCM_OBJ_CLASS_FLAGS (x)
-#define SCM_SIMPLEMETHODP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_SIMPLE_METHOD))
-#define SCM_FASTMETHODP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) \
- & (SCM_CLASSF_ACCESSOR_METHOD \
- | SCM_CLASSF_SIMPLE_METHOD)))
-
-
-#endif
-
#endif /* SCM_GOOPS_H */
/*
SCM (*fcn) ())
{
SCM subr;
+ unsigned type;
- switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
- {
- case SCM_GSUBR_MAKTYPE(0, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(1, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(0, 1, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(1, 1, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(2, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(3, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(0, 0, 1):
- subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(2, 0, 1):
- subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
- break;
- default:
- {
- unsigned type;
-
- type = SCM_GSUBR_MAKTYPE (req, opt, rst);
- if (SCM_GSUBR_REQ (type) != req
- || SCM_GSUBR_OPT (type) != opt
- || SCM_GSUBR_REST (type) != rst)
- scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
-
- subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
- fcn);
- }
- }
+ type = SCM_GSUBR_MAKTYPE (req, opt, rst);
+ if (SCM_GSUBR_REQ (type) != req
+ || SCM_GSUBR_OPT (type) != opt
+ || SCM_GSUBR_REST (type) != rst)
+ scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
+
+ subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
+ fcn);
if (define)
scm_define (SCM_SUBR_NAME (subr), subr);
SCM *gf)
{
SCM subr;
+ unsigned type;
- switch (SCM_GSUBR_MAKTYPE(req, opt, rst))
- {
- case SCM_GSUBR_MAKTYPE(0, 0, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(1, 0, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(0, 1, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(1, 1, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(2, 0, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(3, 0, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(0, 0, 1):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(2, 0, 1):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
- create_subr:
- if (define)
- scm_define (SCM_SUBR_NAME (subr), subr);
- return subr;
- default:
- ;
- }
- scm_misc_error ("scm_c_make_gsubr_with_generic",
- "can't make primitive-generic with this arity",
- SCM_EOL);
- return SCM_BOOL_F; /* never reached */
+ type = SCM_GSUBR_MAKTYPE (req, opt, rst);
+ if (SCM_GSUBR_REQ (type) != req
+ || SCM_GSUBR_OPT (type) != opt
+ || SCM_GSUBR_REST (type) != rst)
+ scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
+
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_gsubr | (type << 8U),
+ fcn, gf);
+
+ if (define)
+ scm_define (SCM_SUBR_NAME (subr), subr);
+
+ return subr;
}
SCM
argv[argc] = arg;
if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
+ /* too few args */
+ scm_wrong_num_args (SCM_SUBR_NAME (proc));
+ if (SCM_UNLIKELY (!SCM_UNBNDP (arg) && !SCM_GSUBR_REST (type)))
+ /* too many args */
scm_wrong_num_args (SCM_SUBR_NAME (proc));
/* Fill in optional arguments that were not passed. */
}
#undef FUNC_NAME
+/* Apply SELF, a gsubr, to the arguments in ARGS. Missing optional
+ arguments are added, and rest arguments are consed into a list. */
+SCM
+scm_i_gsubr_apply_array (SCM self, SCM *args, int nargs, int headroom)
+#define FUNC_NAME "scm_i_gsubr_apply"
+{
+ unsigned int typ = SCM_GSUBR_TYPE (self);
+ long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
+
+ if (SCM_UNLIKELY (nargs < SCM_GSUBR_REQ (typ)))
+ scm_wrong_num_args (SCM_SUBR_NAME (self));
+
+ if (SCM_UNLIKELY (headroom < n - nargs))
+ {
+ /* fallback on apply-list */
+ SCM arglist = SCM_EOL;
+ while (nargs--)
+ arglist = scm_cons (args[nargs], arglist);
+ return scm_i_gsubr_apply_list (self, arglist);
+ }
+
+ for (i = nargs; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++)
+ args[i] = SCM_UNDEFINED;
+
+ if (SCM_GSUBR_REST(typ))
+ {
+ SCM rest = SCM_EOL;
+ /* fallback on apply-list */
+ while (nargs-- >= n)
+ rest = scm_cons (args[nargs], rest);
+ args[n - 1] = rest;
+ }
+ else if (nargs > n)
+ scm_wrong_num_args (SCM_SUBR_NAME (self));
+
+ return gsubr_apply_raw (self, n, args);
+}
+#undef FUNC_NAME
+
#ifdef GSUBR_TEST
/* A silly example, taking 2 required args, 1 optional, and
SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...);
SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args);
+SCM_INTERNAL SCM scm_i_gsubr_apply_array (SCM proc, SCM *args, int nargs,
+ int headroom);
SCM_INTERNAL void scm_init_gsubr (void);
#endif /* SCM_GSUBR_H */
-/* Copyright (C) 1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009 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
*/
\f
-
/* This is an implementation of guardians as described in
* R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
* a Generation-Based Garbage Collector" ACM SIGPLAN Conference on
* Now they should again behave like those described in the paper.
* Scheme guardians should be simple and friendly, not like the greedy
* monsters we had...
+ *
+ * Rewritten for the Boehm-Demers-Weiser GC by Ludovic Courtès.
+ * FIXME: This is currently not thread-safe.
*/
+/* Uncomment the following line to debug guardian finalization. */
+/* #define DEBUG_GUARDIANS 1 */
+
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/eval.h"
#include "libguile/guardians.h"
+#include "libguile/bdw-gc.h"
-/* The live and zombies FIFOs are implemented as tconcs as described
- in Dybvig's paper. This decouples addition and removal of elements
- so that no synchronization between these needs to take place.
-*/
-
-typedef struct t_tconc
-{
- SCM head;
- SCM tail;
-} t_tconc;
-
-#define TCONC_EMPTYP(tc) (scm_is_eq ((tc).head, (tc).tail))
-
-#define TCONC_IN(tc, obj, pair) \
-do { \
- SCM_SETCAR ((tc).tail, obj); \
- SCM_SET_CELL_OBJECT_1 (pair, SCM_EOL); \
- SCM_SET_CELL_OBJECT_0 (pair, SCM_BOOL_F); \
- SCM_SETCDR ((tc).tail, pair); \
- (tc).tail = pair; \
-} while (0)
-
-#define TCONC_OUT(tc, res) \
-do { \
- (res) = SCM_CAR ((tc).head); \
- (tc).head = SCM_CDR ((tc).head); \
-} while (0)
static scm_t_bits tc16_guardian;
typedef struct t_guardian
{
- t_tconc live;
- t_tconc zombies;
+ unsigned long live;
+ SCM zombies;
struct t_guardian *next;
} t_guardian;
#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
-#define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))
-
-static t_guardian *guardians;
+#define GUARDIAN_DATA(x) ((t_guardian *) SCM_SMOB_DATA_1 (x))
-void
-scm_i_init_guardians_for_gc ()
-{
- guardians = NULL;
-}
-
-/* mark a guardian by adding it to the live guardian list. */
-static SCM
-guardian_mark (SCM ptr)
-{
- t_guardian *g = GUARDIAN_DATA (ptr);
- g->next = guardians;
- guardians = g;
- return SCM_BOOL_F;
-}
-/* Identify inaccessible objects and move them from the live list to
- the zombie list. An object is inaccessible when it is unmarked at
- this point. Therefore, the inaccessible objects are not marked yet
- since that would prevent them from being recognized as
- inaccessible.
- The pairs that form the life list itself are marked, tho.
-*/
-void
-scm_i_identify_inaccessible_guardeds ()
+static int
+guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- t_guardian *g;
+ t_guardian *g = GUARDIAN_DATA (guardian);
+
+ scm_puts ("#<guardian ", port);
+ scm_uintprint ((scm_t_bits) g, 16, port);
- for (g = guardians; g; g = g->next)
- {
- SCM pair, next_pair;
- SCM *prev_ptr;
+ scm_puts (" (reachable: ", port);
+ scm_display (scm_from_uint (g->live), port);
+ scm_puts (" unreachable: ", port);
+ scm_display (scm_length (g->zombies), port);
+ scm_puts (")", port);
- for (pair = g->live.head, prev_ptr = &g->live.head;
- !scm_is_eq (pair, g->live.tail);
- pair = next_pair)
- {
- SCM obj = SCM_CAR (pair);
- next_pair = SCM_CDR (pair);
- if (!SCM_GC_MARK_P (obj))
- {
- /* Unmarked, move to 'inaccessible' list.
- */
- *prev_ptr = next_pair;
- TCONC_IN (g->zombies, obj, pair);
- }
- else
- {
- SCM_SET_GC_MARK (pair);
- prev_ptr = SCM_CDRLOC (pair);
- }
- }
- SCM_SET_GC_MARK (pair);
- }
+ scm_puts (">", port);
+
+ return 1;
}
-int
-scm_i_mark_inaccessible_guardeds ()
+/* Handle finalization of OBJ which is guarded by the guardians listed in
+ GUARDIAN_LIST. */
+static void
+finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
{
- t_guardian *g;
- int again = 0;
+ SCM cell_pool;
+ SCM obj, guardian_list, proxied_finalizer;
- /* We never need to see the guardians again that are processed here,
- so we clear the list. Calling scm_gc_mark below might find new
- guardians, however (and other things), and we inform the GC about
- this by returning non-zero. See scm_mark_all in gc-mark.c
- */
+ obj = PTR2SCM (ptr);
+ guardian_list = SCM_CDR (PTR2SCM (finalizer_data));
+ proxied_finalizer = SCM_CAR (PTR2SCM (finalizer_data));
- g = guardians;
- guardians = NULL;
+#ifdef DEBUG_GUARDIANS
+ printf ("finalizing guarded %p (%u guardians)\n",
+ ptr, scm_to_uint (scm_length (guardian_list)));
+#endif
- for (; g; g = g->next)
+ /* Preallocate a bunch of cells so that we can make sure that no garbage
+ collection (and, thus, nested calls to `finalize_guarded ()') occurs
+ while executing the following loop. This is quite inefficient (call to
+ `scm_length ()') but that shouldn't be a problem in most cases. */
+ cell_pool = scm_make_list (scm_length (guardian_list), SCM_UNSPECIFIED);
+
+ /* Tell each guardian interested in OBJ that OBJ is no longer
+ reachable. */
+ for (;
+ guardian_list != SCM_EOL;
+ guardian_list = SCM_CDR (guardian_list))
{
- SCM pair;
+ SCM zombies;
+ t_guardian *g;
- for (pair = g->zombies.head;
- !scm_is_eq (pair, g->zombies.tail);
- pair = SCM_CDR (pair))
+ if (SCM_WEAK_PAIR_CAR_DELETED_P (guardian_list))
{
- if (!SCM_GC_MARK_P (pair))
- {
- scm_gc_mark (SCM_CAR (pair));
- SCM_SET_GC_MARK (pair);
- again = 1;
- }
+ /* The guardian itself vanished in the meantime. */
+#ifdef DEBUG_GUARDIANS
+ printf (" guardian for %p vanished\n", ptr);
+#endif
+ continue;
}
- SCM_SET_GC_MARK (pair);
+
+ g = GUARDIAN_DATA (SCM_CAR (guardian_list));
+ if (g->live == 0)
+ abort ();
+
+ /* Get a fresh cell from CELL_POOL. */
+ zombies = cell_pool;
+ cell_pool = SCM_CDR (cell_pool);
+
+ /* Compute and update G's zombie list. */
+ SCM_SETCAR (zombies, SCM_PACK (obj));
+ SCM_SETCDR (zombies, g->zombies);
+ g->zombies = zombies;
+
+ g->live--;
+ g->zombies = zombies;
}
- return again;
-}
-static size_t
-guardian_free (SCM ptr)
-{
- scm_gc_free (GUARDIAN_DATA (ptr), sizeof (t_guardian), "guardian");
- return 0;
-}
+ if (proxied_finalizer != SCM_BOOL_F)
+ {
+ /* Re-register the finalizer that was in place before we installed this
+ one. */
+ GC_finalization_proc finalizer, prev_finalizer;
+ GC_PTR finalizer_data, prev_finalizer_data;
-static int
-guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- t_guardian *g = GUARDIAN_DATA (guardian);
-
- scm_puts ("#<guardian ", port);
- scm_uintprint ((scm_t_bits) g, 16, port);
+ finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer));
+ finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer));
- scm_puts (" (reachable: ", port);
- scm_display (scm_length (SCM_CDR (g->live.head)), port);
- scm_puts (" unreachable: ", port);
- scm_display (scm_length (SCM_CDR (g->zombies.head)), port);
- scm_puts (")", port);
+ if (finalizer == NULL)
+ abort ();
- scm_puts (">", port);
+ GC_REGISTER_FINALIZER_NO_ORDER (ptr, finalizer, finalizer_data,
+ &prev_finalizer, &prev_finalizer_data);
- return 1;
+#ifdef DEBUG_GUARDIANS
+ printf (" reinstalled proxied finalizer %p for %p\n", finalizer, ptr);
+#endif
+ }
+
+#ifdef DEBUG_GUARDIANS
+ printf ("end of finalize (%p)\n", ptr);
+#endif
}
+/* Add OBJ as a guarded object of GUARDIAN. */
static void
scm_i_guard (SCM guardian, SCM obj)
{
t_guardian *g = GUARDIAN_DATA (guardian);
-
- if (!SCM_IMP (obj))
+
+ if (SCM_NIMP (obj))
{
- SCM z;
- z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
- TCONC_IN (g->live, obj, z);
+ /* Register a finalizer and pass a pair as the ``client data''
+ argument. The pair contains in its car `#f' or a pair describing a
+ ``proxied'' finalizer (see below); its cdr contains a list of
+ guardians interested in OBJ.
+
+ A ``proxied'' finalizer is a finalizer that was registered for OBJ
+ before OBJ became guarded (e.g., a SMOB `free' function). We are
+ assuming here that finalizers are only used internally, either at
+ the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB')
+ or by this function. */
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_data;
+ SCM guardians_for_obj, finalizer_data;
+
+ g->live++;
+
+ /* Note: GUARDIANS_FOR_OBJ is a weak list so that a guardian can be
+ collected before the objects it guards (see `guardians.test'). */
+ guardians_for_obj = scm_weak_car_pair (guardian, SCM_EOL);
+ finalizer_data = scm_cons (SCM_BOOL_F, guardians_for_obj);
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalize_guarded,
+ SCM2PTR (finalizer_data),
+ &prev_finalizer, &prev_data);
+
+ if (prev_finalizer == finalize_guarded)
+ {
+ /* OBJ is already guarded by another guardian: add GUARDIAN to its
+ list of guardians. */
+ SCM prev_guardian_list, prev_finalizer_data;
+
+ if (prev_data == NULL)
+ abort ();
+
+ prev_finalizer_data = PTR2SCM (prev_data);
+ if (!scm_is_pair (prev_finalizer_data))
+ abort ();
+
+ prev_guardian_list = SCM_CDR (prev_finalizer_data);
+ SCM_SETCDR (guardians_for_obj, prev_guardian_list);
+
+ /* Also copy information about proxied finalizers. */
+ SCM_SETCAR (finalizer_data, SCM_CAR (prev_finalizer_data));
+ }
+ else if (prev_finalizer != NULL)
+ {
+ /* There was already a finalizer registered for OBJ so we will
+ ``proxy'' it, i.e., record it so that we can re-register it once
+ `finalize_guarded ()' has finished. */
+ SCM proxied_finalizer;
+
+ proxied_finalizer = scm_cons (PTR2SCM (prev_finalizer),
+ PTR2SCM (prev_data));
+ SCM_SETCAR (finalizer_data, proxied_finalizer);
+ }
}
}
t_guardian *g = GUARDIAN_DATA (guardian);
SCM res = SCM_BOOL_F;
- if (!TCONC_EMPTYP (g->zombies))
- TCONC_OUT (g->zombies, res);
+ if (g->zombies != SCM_EOL)
+ {
+ /* Note: We return zombies in reverse order. */
+ res = SCM_CAR (g->zombies);
+ g->zombies = SCM_CDR (g->zombies);
+ }
return res;
}
static SCM
guardian_apply (SCM guardian, SCM obj, SCM throw_p)
{
-#if ENABLE_DEPRECATED
- if (!SCM_UNBNDP (throw_p))
- scm_c_issue_deprecation_warning
- ("Using the 'throw?' argument of a guardian is deprecated "
- "and ineffective.");
-#endif
-
if (!SCM_UNBNDP (obj))
{
scm_i_guard (guardian, obj);
#define FUNC_NAME s_scm_make_guardian
{
t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
- SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL);
- SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL);
SCM z;
/* A tconc starts out with one tail pair. */
- g->live.head = g->live.tail = z1;
- g->zombies.head = g->zombies.tail = z2;
+ g->live = 0;
+ g->zombies = SCM_EOL;
g->next = NULL;
void
scm_init_guardians ()
{
+ /* We use unordered finalization `a la Java. */
+ GC_java_finalization = 1;
+
tc16_guardian = scm_make_smob_type ("guardian", 0);
- scm_set_smob_mark (tc16_guardian, guardian_mark);
- scm_set_smob_free (tc16_guardian, guardian_free);
+
scm_set_smob_print (tc16_guardian, guardian_print);
-#if ENABLE_DEPRECATED
- scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0);
-#else
scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0);
-#endif
#include "libguile/guardians.x"
}
#!/bin/sh
# Extract the initialization actions from source files.
#
-# Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
+# Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
## empty file.
echo "/* cpp arguments: $@ */" ;
${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true
- grep "^ *\^ *\^" ${temp} | sed -e "s/^ *\^ *\^//" -e "s/\^\ *:\ *\^.*/;/"
+ grep "^ *\^ *\^" ${temp} | sed -e "s/ *\^ *\^//g" -e "s/\^ *: *\^/;/g"
}
## main
-/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009 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
else return 1;
case scm_tc7_port:
return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
- case scm_tcs_closures:
- case scm_tcs_subrs:
+ /* case scm_tcs_closures: */
+ case scm_tc7_gsubr:
return 262 % n;
}
}
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 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
#endif
#include <stdio.h>
+#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/validate.h"
#include "libguile/hashtab.h"
+
+
\f
/* NOTES
*
*/
-/* Hash tables are either vectors of association lists or smobs
- * containing such vectors. Currently, the vector version represents
- * constant size tables while those wrapped in a smob represents
- * resizing tables.
+/* A hash table is a cell containing a vector of association lists.
*
* Growing or shrinking, with following rehashing, is triggered when
* the load factor
* hashtable_size.
*/
-scm_t_bits scm_tc16_hashtable;
-
static unsigned long hashtable_size[] = {
31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
static char *s_hashtable = "hashtable";
-SCM weak_hashtables = SCM_EOL;
+\f
+/* Helper functions and macros to deal with weak pairs.
+
+ Weak pairs need to be accessed very carefully since their components can
+ be nullified by the GC when the object they refer to becomes unreachable.
+ Hence the macros and functions below that detect such weak pairs within
+ buckets and remove them. */
+
+
+/* Remove nullified weak pairs from ALIST such that the result contains only
+ valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
+ deleted. */
+static SCM
+scm_fixup_weak_alist (SCM alist, size_t *removed_items)
+{
+ SCM result;
+ SCM prev = SCM_EOL;
+
+ *removed_items = 0;
+ for (result = alist;
+ scm_is_pair (alist);
+ prev = alist, alist = SCM_CDR (alist))
+ {
+ SCM pair = SCM_CAR (alist);
+
+ if (scm_is_pair (pair))
+ {
+ if (SCM_WEAK_PAIR_DELETED_P (pair))
+ {
+ /* Remove from ALIST weak pair PAIR whose car/cdr has been
+ nullified by the GC. */
+ if (prev == SCM_EOL)
+ result = SCM_CDR (alist);
+ else
+ SCM_SETCDR (prev, SCM_CDR (alist));
+
+ (*removed_items)++;
+ continue;
+ }
+ }
+ }
+
+ return result;
+}
+
+
+/* Return true if OBJ is either a weak hash table or a weak alist vector (as
+ defined in `weaks.[ch]').
+ FIXME: We should eventually keep only weah hash tables. Actually, the
+ procs in `weaks.c' already no longer return vectors. */
+/* XXX: We assume that if OBJ is a vector, then it's a _weak_ alist vector. */
+#define IS_WEAK_THING(_obj) \
+ ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table))) \
+ || (SCM_I_IS_VECTOR (table)))
+
+
+/* Packed arguments for `do_weak_bucket_assoc ()'. */
+struct t_assoc_args
+{
+ /* Input arguments. */
+ SCM object;
+ SCM buckets;
+ size_t bucket_index;
+ scm_t_assoc_fn assoc_fn;
+ void *closure;
+
+ /* Output arguments. */
+ SCM result;
+ size_t removed_items;
+};
+
+static void *
+do_weak_bucket_assoc (void *data)
+{
+ struct t_assoc_args *args;
+ size_t removed;
+ SCM bucket, result;
+
+ args = (struct t_assoc_args *) data;
+
+ bucket = SCM_SIMPLE_VECTOR_REF (args->buckets, args->bucket_index);
+ bucket = scm_fixup_weak_alist (bucket, &removed);
+
+ SCM_SIMPLE_VECTOR_SET (args->buckets, args->bucket_index, bucket);
+
+ /* Run ASSOC_FN on the now clean BUCKET. */
+ result = args->assoc_fn (args->object, bucket, args->closure);
+
+ args->result = result;
+ args->removed_items = removed;
+
+ return args;
+}
+
+/* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
+ for in the alist that is the BUCKET_INDEXth element of BUCKETS.
+ Optionally update TABLE and rehash it. */
+static SCM
+weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc, SCM object, void *closure)
+{
+ SCM result;
+ struct t_assoc_args args;
+
+ args.object = object;
+ args.buckets = buckets;
+ args.bucket_index = bucket_index;
+ args.assoc_fn = assoc;
+ args.closure = closure;
+
+ /* Fixup the bucket and pass the clean bucket to ASSOC. Do that with the
+ allocation lock held to avoid seeing disappearing links pointing to
+ objects that have already been reclaimed (this happens when the
+ disappearing links that point to it haven't yet been cleared.)
+ Thus, ASSOC must not take long, and it must not make any non-local
+ exit. */
+ GC_call_with_alloc_lock (do_weak_bucket_assoc, &args);
+
+ result = args.result;
+ assert (!scm_is_pair (result) ||
+ !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result)));
+
+ if (args.removed_items > 0 && SCM_HASHTABLE_P (table))
+ {
+ /* Update TABLE's item count and optionally trigger a rehash. */
+ size_t remaining;
+
+ assert (SCM_HASHTABLE_N_ITEMS (table) >= args.removed_items);
+
+ remaining = SCM_HASHTABLE_N_ITEMS (table) - args.removed_items;
+ SCM_SET_HASHTABLE_N_ITEMS (table, remaining);
+
+ scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
+ }
+
+ return result;
+}
+
+
+\f
static SCM
make_hash_table (int flags, unsigned long k, const char *func_name)
{
- SCM table, vector;
+ SCM vector;
scm_t_hashtable *t;
int i = 0, n = k ? k : 31;
while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
n = hashtable_size[i];
- if (flags)
- vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL);
- else
- vector = scm_c_make_vector (n, SCM_EOL);
- t = scm_gc_malloc (sizeof (*t), s_hashtable);
+
+ /* In both cases, i.e., regardless of whether we are creating a weak hash
+ table, we return a non-weak vector. This is because the vector itself
+ is not weak in the case of a weak hash table: the alist pairs are. */
+ vector = scm_c_make_vector (n, SCM_EOL);
+
+ t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
t->min_size_index = t->size_index = i;
t->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
t->flags = flags;
t->hash_fn = NULL;
- if (flags)
- {
- SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
- weak_hashtables = table;
- }
- else
- SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL);
- return table;
+
+ /* FIXME: we just need two words of storage, not three */
+ return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
+ (scm_t_bits)t, 0);
}
void
scm_i_rehash (SCM table,
- unsigned long (*hash_fn)(),
+ scm_t_hash_fn hash_fn,
void *closure,
const char* func_name)
{
SCM_HASHTABLE (table)->lower = new_size / 4;
SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
buckets = SCM_HASHTABLE_VECTOR (table);
-
- if (SCM_HASHTABLE_WEAK_P (table))
- new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table),
- scm_from_ulong (new_size),
- SCM_EOL);
- else
- new_buckets = scm_c_make_vector (new_size, SCM_EOL);
+
+ new_buckets = scm_c_make_vector (new_size, SCM_EOL);
/* When this is a weak hashtable, running the GC might change it.
We need to cope with this while rehashing its elements. We do
while (scm_is_pair (ls))
{
unsigned long h;
+
cell = ls;
handle = SCM_CAR (cell);
ls = SCM_CDR (ls);
+
+ if (SCM_WEAK_PAIR_DELETED_P (handle))
+ /* HANDLE is a nullified weak pair: skip it. */
+ continue;
+
h = hash_fn (SCM_CAR (handle), new_size, closure);
if (h >= new_size)
scm_out_of_range (func_name, scm_from_ulong (h));
}
-static int
-hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+void
+scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<", port);
if (SCM_HASHTABLE_WEAK_KEY_P (exp))
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
scm_puts (">", port);
- return 1;
-}
-
-/* keep track of hash tables that need to shrink after scan */
-static SCM to_rehash = SCM_EOL;
-
-/* scan hash tables and update hash tables item count */
-void
-scm_i_scan_weak_hashtables ()
-{
- SCM *next = &weak_hashtables;
- SCM h = *next;
- while (!scm_is_null (h))
- {
- if (!SCM_GC_MARK_P (h))
- *next = h = SCM_HASHTABLE_NEXT (h);
- else
- {
- SCM vec = SCM_HASHTABLE_VECTOR (h);
- size_t delta = SCM_I_WVECT_DELTA (vec);
- SCM_I_SET_WVECT_DELTA (vec, 0);
- SCM_SET_HASHTABLE_N_ITEMS (h, SCM_HASHTABLE_N_ITEMS (h) - delta);
-
- if (SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h))
- {
- SCM tmp = SCM_HASHTABLE_NEXT (h);
- /* temporarily move table from weak_hashtables to to_rehash */
- SCM_SET_HASHTABLE_NEXT (h, to_rehash);
- to_rehash = h;
- *next = h = tmp;
- }
- else
- {
- next = SCM_HASHTABLE_NEXTLOC (h);
- h = SCM_HASHTABLE_NEXT (h);
- }
- }
- }
-}
-
-static void *
-rehash_after_gc (void *dummy1 SCM_UNUSED,
- void *dummy2 SCM_UNUSED,
- void *dummy3 SCM_UNUSED)
-{
- if (!scm_is_null (to_rehash))
- {
- SCM first = to_rehash, last, h;
- /* important to clear to_rehash here so that we don't get stuck
- in an infinite loop if scm_i_rehash causes GC */
- to_rehash = SCM_EOL;
- h = first;
- do
- {
- /* Rehash only when we have a hash_fn.
- */
- if (SCM_HASHTABLE (h)->hash_fn)
- scm_i_rehash (h, SCM_HASHTABLE (h)->hash_fn, NULL,
- "rehash_after_gc");
- last = h;
- h = SCM_HASHTABLE_NEXT (h);
- } while (!scm_is_null (h));
- /* move tables back to weak_hashtables */
- SCM_SET_HASHTABLE_NEXT (last, weak_hashtables);
- weak_hashtables = first;
- }
- return 0;
-}
-
-static size_t
-hashtable_free (SCM obj)
-{
- scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable);
- return 0;
}
}
#undef FUNC_NAME
+\f
+/* Accessing hash table entries. */
SCM
-scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
+scm_hash_fn_get_handle (SCM table, SCM obj,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void * closure)
#define FUNC_NAME "scm_hash_fn_get_handle"
{
unsigned long k;
- SCM h;
+ SCM buckets, h;
if (SCM_HASHTABLE_P (table))
- table = SCM_HASHTABLE_VECTOR (table);
+ buckets = SCM_HASHTABLE_VECTOR (table);
else
- SCM_VALIDATE_VECTOR (1, table);
- if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
+ {
+ SCM_VALIDATE_VECTOR (1, table);
+ buckets = table;
+ }
+
+ if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
return SCM_BOOL_F;
- k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (table), closure);
- if (k >= SCM_SIMPLE_VECTOR_LENGTH (table))
+ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
+ if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k));
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (table, k), closure);
+
+ if (IS_WEAK_THING (table))
+ h = weak_bucket_assoc (table, buckets, k, hash_fn,
+ assoc_fn, obj, closure);
+ else
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+
return h;
}
#undef FUNC_NAME
SCM
-scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void * closure)
#define FUNC_NAME "scm_hash_fn_create_handle_x"
{
unsigned long k;
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+
+ if (IS_WEAK_THING (table))
+ it = weak_bucket_assoc (table, buckets, k, hash_fn,
+ assoc_fn, obj, closure);
+ else
+ it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+
if (scm_is_pair (it))
return it;
else if (scm_is_true (it))
again since the hashtable might have been rehashed. This
necessitates a new hash value as well.
*/
- SCM new_bucket = scm_acons (obj, init, SCM_EOL);
+ SCM handle, new_bucket;
+
+ if ((SCM_HASHTABLE_P (table)) && (SCM_HASHTABLE_WEAK_P (table)))
+ {
+ /* FIXME: We don't support weak alist vectors. */
+ /* Use a weak cell. */
+ if (SCM_HASHTABLE_DOUBLY_WEAK_P (table))
+ handle = scm_doubly_weak_pair (obj, init);
+ else if (SCM_HASHTABLE_WEAK_KEY_P (table))
+ handle = scm_weak_car_pair (obj, init);
+ else
+ handle = scm_weak_cdr_pair (obj, init);
+ }
+ else
+ /* Use a regular, non-weak cell. */
+ handle = scm_cons (obj, init);
+
+ new_bucket = scm_cons (handle, SCM_EOL);
+
if (!scm_is_eq (table, buckets)
&& !scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
{
#undef FUNC_NAME
-SCM
-scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+SCM
+scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void *closure)
{
SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
if (scm_is_pair (it))
-SCM
-scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+SCM
+scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void *closure)
{
SCM it;
}
-SCM
+SCM
scm_hash_fn_remove_x (SCM table, SCM obj,
- unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(),
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
void *closure)
{
unsigned long k;
SCM_ARG1, "hash_fn_remove_x");
buckets = table;
}
- if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
+ if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
return SCM_EOL;
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k));
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+
+ if (IS_WEAK_THING (table))
+ h = weak_bucket_assoc (table, buckets, k, hash_fn,
+ assoc_fn, obj, closure);
+ else
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+
if (scm_is_true (h))
{
SCM_SIMPLE_VECTOR_SET
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_get_handle (table, key,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_create_handle_x (table, key, init,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
"store @var{value} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
- return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_get_handle (table, key,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv,
- scm_sloppy_assv, 0);
+ return scm_hash_fn_create_handle_x (table, key, init,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
"store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
- return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_get_handle (table, key,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_create_handle_x (table, key, init,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
- return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
static unsigned long
-scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure)
+scm_ihashx (SCM obj, unsigned long n, void *arg)
{
- SCM answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
+ SCM answer;
+ scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
+ answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
return scm_to_ulong (answer);
}
static SCM
-scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure)
+scm_sloppy_assx (SCM obj, SCM alist, void *arg)
{
+ scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
return scm_call_2 (closure->assoc, obj, alist);
}
static const char s_scm_hash_fold[];
SCM
-scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
+scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
+ SCM init, SCM table)
{
long i, n;
SCM buckets, result = init;
if (SCM_HASHTABLE_P (table))
buckets = SCM_HASHTABLE_VECTOR (table);
else
+ /* Weak alist vector. */
buckets = table;
n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
for (i = 0; i < n; ++i)
{
- SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
- while (!scm_is_null (ls))
+ SCM prev, ls;
+
+ for (prev = SCM_BOOL_F, ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
+ !scm_is_null (ls);
+ prev = ls, ls = SCM_CDR (ls))
{
+ SCM handle;
+
if (!scm_is_pair (ls))
scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
+
handle = SCM_CAR (ls);
if (!scm_is_pair (handle))
scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
+
+ if (IS_WEAK_THING (table))
+ {
+ if (SCM_WEAK_PAIR_DELETED_P (handle))
+ {
+ /* We hit a weak pair whose car/cdr has become
+ unreachable: unlink it from the bucket. */
+ if (prev != SCM_BOOL_F)
+ SCM_SETCDR (prev, SCM_CDR (ls));
+ else
+ SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls));
+
+ if (SCM_HASHTABLE_P (table))
+ /* Update the item count. */
+ SCM_HASHTABLE_DECREMENT (table);
+
+ continue;
+ }
+ }
+
result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
- ls = SCM_CDR (ls);
}
}
static const char s_scm_hash_for_each[];
void
-scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table)
+scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure,
+ SCM table)
{
long i, n;
SCM buckets;
SCM_VALIDATE_PROC (1, proc);
if (!SCM_HASHTABLE_P (table))
SCM_VALIDATE_VECTOR (3, table);
- return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (proc), init, table);
+ return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
+ (void *) SCM_UNPACK (proc), init, table);
}
#undef FUNC_NAME
"Applies PROC successively on all hash table handles.")
#define FUNC_NAME s_scm_hash_for_each_handle
{
- scm_t_trampoline_1 call = scm_trampoline_1 (proc);
- SCM_ASSERT (call, proc, 1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
if (!SCM_HASHTABLE_P (table))
SCM_VALIDATE_VECTOR (2, table);
- scm_internal_hash_for_each_handle (call,
+ scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(void *) SCM_UNPACK (proc),
table);
return SCM_UNSPECIFIED;
\f
-void
-scm_hashtab_prehistory ()
-{
- scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0);
- scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr);
- scm_set_smob_print (scm_tc16_hashtable, hashtable_print);
- scm_set_smob_free (scm_tc16_hashtable, hashtable_free);
- scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0);
-}
-
void
scm_init_hashtab ()
{
#ifndef SCM_HASHTAB_H
#define SCM_HASHTAB_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 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
#define SCM_HASHTABLEF_WEAK_CAR SCM_WVECTF_WEAK_KEY
#define SCM_HASHTABLEF_WEAK_CDR SCM_WVECTF_WEAK_VALUE
-SCM_API scm_t_bits scm_tc16_hashtable;
-
-#define SCM_HASHTABLE_P(x) SCM_SMOB_PREDICATE (scm_tc16_hashtable, x)
+#define SCM_HASHTABLE_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_hashtable)
#define SCM_VALIDATE_HASHTABLE(pos, arg) \
SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table")
-#define SCM_HASHTABLE_VECTOR(h) SCM_SMOB_OBJECT (h)
-#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_SMOB_OBJECT ((x), (v))
-#define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_SMOB_DATA_2 (x))
-#define SCM_HASHTABLE_NEXT(x) SCM_SMOB_OBJECT_3 (x)
-#define SCM_HASHTABLE_NEXTLOC(x) SCM_SMOB_OBJECT_3_LOC (x)
-#define SCM_SET_HASHTABLE_NEXT(x, n) SCM_SET_SMOB_OBJECT_3 ((x), (n))
+#define SCM_HASHTABLE_VECTOR(h) SCM_CELL_OBJECT_1 (h)
+#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_CELL_OBJECT_1 ((x), (v))
+#define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_CELL_WORD_2 (x))
#define SCM_HASHTABLE_FLAGS(x) (SCM_HASHTABLE (x)->flags)
#define SCM_HASHTABLE_WEAK_KEY_P(x) \
(SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CAR)
#define SCM_SET_HASHTABLE_BUCKET(h, i, x) \
SCM_SIMPLE_VECTOR_SET (SCM_HASHTABLE_VECTOR (h), i, x)
+/* Function that computes a hash of OBJ modulo MAX. */
+typedef unsigned long (*scm_t_hash_fn) (SCM obj, unsigned long max,
+ void *closure);
+
+/* Function that returns the value associated with OBJ in ALIST according to
+ some equality predicate. */
+typedef SCM (*scm_t_assoc_fn) (SCM obj, SCM alist, void *closure);
+
+/* Function to fold over the entries of a hash table. */
+typedef SCM (*scm_t_hash_fold_fn) (void *closure, SCM key, SCM value,
+ SCM result);
+
+/* Function to iterate over the handles (key-value pairs) of a hash
+ table. */
+typedef SCM (*scm_t_hash_handle_fn) (void *closure, SCM handle);
+
typedef struct scm_t_hashtable {
int flags; /* properties of table */
unsigned long n_items; /* number of items in table */
unsigned long upper; /* when to grow */
int size_index; /* index into hashtable_size */
int min_size_index; /* minimum size_index */
- unsigned long (*hash_fn) (); /* for rehashing after a GC. */
+ scm_t_hash_fn hash_fn; /* for rehashing after a GC. */
} scm_t_hashtable;
\f
-#if 0
-typedef unsigned int scm_t_hash_fn (SCM obj, unsigned int d, void *closure);
-typedef SCM scm_t_assoc_fn (SCM key, SCM alist, void *closure);
-typedef SCM scm_t_delete_fn (SCM elt, SCM list);
-#endif
-
SCM_API SCM scm_vector_to_hash_table (SCM vector);
SCM_API SCM scm_c_make_hash_table (unsigned long k);
SCM_API SCM scm_make_hash_table (SCM n);
SCM_API SCM scm_weak_value_hash_table_p (SCM h);
SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
-SCM_INTERNAL void scm_i_rehash (SCM table, unsigned long (*hash_fn)(),
+SCM_INTERNAL void scm_i_rehash (SCM table, scm_t_hash_fn hash_fn,
void *closure, const char *func_name);
-SCM_INTERNAL void scm_i_scan_weak_hashtables (void);
-
-SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table);
-SCM_API void scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table);
+
+
+SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_hash_fn_remove_x (SCM table, SCM obj,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
+ SCM init, SCM table);
+SCM_API void scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn,
+ void *closure, SCM table);
SCM_API SCM scm_hash_clear_x (SCM table);
SCM_API SCM scm_hashq_get_handle (SCM table, SCM obj);
SCM_API SCM scm_hash_for_each (SCM proc, SCM hash);
SCM_API SCM scm_hash_for_each_handle (SCM proc, SCM hash);
SCM_API SCM scm_hash_map_to_list (SCM proc, SCM hash);
-SCM_INTERNAL void scm_hashtab_prehistory (void);
+SCM_INTERNAL void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_hashtab (void);
#endif /* SCM_HASHTAB_H */
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008, 2009 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
* using C level hooks.
*/
+/* Hint for `scm_gc_malloc ()' and friends. */
+static const char hook_entry_gc_hint[] = "hook entry";
+
void
scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hook_type type)
{
void *fn_data,
int appendp)
{
- scm_t_c_hook_entry *entry = scm_malloc (sizeof (scm_t_c_hook_entry));
+ scm_t_c_hook_entry *entry;
scm_t_c_hook_entry **loc = &hook->first;
+
+ entry = scm_gc_malloc (sizeof (scm_t_c_hook_entry), hook_entry_gc_hint);
if (appendp)
while (*loc)
loc = &(*loc)->next;
{
if ((*loc)->func == func && (*loc)->data == fn_data)
{
- scm_t_c_hook_entry *entry = *loc;
*loc = (*loc)->next;
- free (entry);
return;
}
loc = &(*loc)->next;
"procedure is not specified.")
#define FUNC_NAME s_scm_add_hook_x
{
- SCM arity, rest;
- int n_args;
+ SCM rest;
+ int n_args, p_req, p_opt, p_rest;
SCM_VALIDATE_HOOK (1, hook);
- SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (proc)),
+ SCM_ASSERT (scm_i_procedure_arity (proc, &p_req, &p_opt, &p_rest),
proc, SCM_ARG2, FUNC_NAME);
n_args = SCM_HOOK_ARITY (hook);
- if (scm_to_int (SCM_CAR (arity)) > n_args
- || (scm_is_false (SCM_CADDR (arity))
- && (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity))
- < n_args)))
+ if (p_req > n_args || (!p_rest && p_req + p_opt < n_args))
scm_wrong_type_arg (FUNC_NAME, 2, proc);
rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
SCM_SET_HOOK_PROCEDURES (hook,
scm_init_hooks ()
{
scm_tc16_hook = scm_make_smob_type ("hook", 0);
- scm_set_smob_mark (scm_tc16_hook, scm_markcdr);
scm_set_smob_print (scm_tc16_hook, hook_print);
#include "libguile/hooks.x"
}
-/* Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2007, 2008, 2009 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
#include <alloca.h>
#include "libguile/_scm.h"
+#include "libguile/extensions.h"
#include "libguile/feature.h"
#include "libguile/i18n.h"
#include "libguile/strings.h"
#include <string.h> /* `strcoll ()' */
#include <ctype.h> /* `toupper ()' et al. */
#include <errno.h>
+#include <unicase.h>
+#include <unistr.h>
#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
/* The GNU thread-aware locale API is documented in ``Thread-Aware Locale
# define USE_GNU_LOCALE_API
#endif
-#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
-# include <xlocale.h>
-#endif
-
#include "libguile/posix.h" /* for `scm_i_locale_mutex' */
#if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H)
return 0;
}
-#ifndef USE_GNU_LOCALE_API
-static SCM
-smob_locale_mark (SCM locale)
-{
- register SCM dependency;
-
- if (!scm_is_eq (locale, SCM_VARIABLE_REF (scm_global_locale)))
- {
- scm_t_locale c_locale;
-
- c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
- dependency = (c_locale->base_locale);
- }
- else
- dependency = SCM_BOOL_F;
-
- return dependency;
-}
-#endif
-
static void inline scm_locale_error (const char *, int) SCM_NORETURN;
return err;
}
+#else /* USE_GNU_LOCALE_API */
+
+/* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
+#define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
+ do \
+ { \
+ scm_t_locale old_loc; \
+ \
+ old_loc = uselocale (_c_locale); \
+ _statement ; \
+ uselocale (old_loc); \
+ } \
+ while (0)
+
-#endif /* !USE_GNU_LOCALE_API */
+#endif /* USE_GNU_LOCALE_API */
\f
#ifdef USE_GNU_LOCALE_API
if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
- {
- /* Fetch the current locale and turn in into a `locale_t'. Don't
- duplicate the resulting `locale_t' because we want it to be consumed
- by `newlocale ()'. */
- char *current_locale;
-
- scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
-
- current_locale = setlocale (LC_ALL, NULL);
- c_base_locale = newlocale (LC_ALL_MASK, current_locale, NULL);
+ c_base_locale = LC_GLOBAL_LOCALE;
- scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
-
- if (c_base_locale == (locale_t) 0)
- scm_locale_error (FUNC_NAME, errno);
- }
- else if (c_base_locale != (locale_t) 0)
+ if (c_base_locale != (locale_t) 0)
{
/* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be
duplicated before. */
c_base_locale = duplocale (c_base_locale);
+
if (c_base_locale == (locale_t) 0)
{
err = errno;
if (c_locale == (locale_t) 0)
{
- if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
- /* The base locale object was created lazily and must be freed. */
+ if (c_base_locale != (locale_t) 0)
freelocale (c_base_locale);
-
scm_locale_error (FUNC_NAME, errno);
}
else
A similar API can be found in MzScheme starting from version 200:
http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */
+#define SCM_STRING_TO_U32_BUF(s1, c_s1) \
+ do \
+ { \
+ if (scm_i_is_narrow_string (s1)) \
+ { \
+ size_t i, len; \
+ const char *buf = scm_i_string_chars (s1); \
+ \
+ len = scm_i_string_length (s1); \
+ c_s1 = alloca (sizeof (scm_t_wchar) * (len + 1)); \
+ \
+ for (i = 0; i < len; i ++) \
+ c_s1[i] = (unsigned char ) buf[i]; \
+ c_s1[len] = 0; \
+ } \
+ else \
+ c_s1 = (scm_t_wchar *) scm_i_string_wide_chars (s1); \
+ } while (0)
-/* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return
- an integer whose sign is the same as the difference between C_S1 and
- C_S2. */
+
+/* Compare UTF-32 strings according to LOCALE. Returns a negative value if
+ S1 compares smaller than S2, a positive value if S1 compares larger than
+ S2, or 0 if they compare equal. */
static inline int
-compare_strings (const char *c_s1, const char *c_s2, SCM locale,
- const char *func_name)
+compare_u32_strings (SCM s1, SCM s2, SCM locale, const char *func_name)
#define FUNC_NAME func_name
{
int result;
scm_t_locale c_locale;
+ scm_t_wchar *c_s1, *c_s2;
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
+
+ SCM_STRING_TO_U32_BUF (s1, c_s1);
+ SCM_STRING_TO_U32_BUF (s2, c_s2);
+ if (c_locale)
+ RUN_IN_LOCALE_SECTION (c_locale,
+ result = u32_strcoll ((const scm_t_uint32 *) c_s1,
+ (const scm_t_uint32 *) c_s2));
+ else
+ result = u32_strcoll ((const scm_t_uint32 *) c_s1,
+ (const scm_t_uint32 *) c_s2);
+
+ scm_remember_upto_here_2 (s1, s2);
+ scm_remember_upto_here (locale);
+ return result;
+}
+#undef FUNC_NAME
+
+/* Return the current language of the locale. */
+static const char *
+locale_language ()
+{
+ /* FIXME: If the locale has been set with 'uselocale',
+ libunistring's uc_locale_language will return the incorrect
+ language: it will return the language appropriate for the global
+ (non-thread-specific) locale.
+
+ There appears to be no portable way to extract the language from
+ the thread-specific locale_t. There is no LANGUAGE capability in
+ nl_langinfo or nl_langinfo_l.
+
+ Thus, uc_locale_language needs to be fixed upstream. */
+ return uc_locale_language ();
+}
+
+static inline int
+u32_locale_casecoll (const char *func_name, const scm_t_uint32 *c_s1,
+ const scm_t_uint32 *c_s2,
+ int *result)
+{
+ /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must note
+ make any non-local exit. */
+
+ int ret;
+ const char *loc = locale_language ();
+
+ ret = u32_casecoll (c_s1, u32_strlen (c_s1),
+ c_s2, u32_strlen (c_s2),
+ loc, UNINORM_NFC, result);
+
+ return ret == 0 ? ret : errno;
+}
+
+static inline int
+compare_u32_strings_ci (SCM s1, SCM s2, SCM locale, const char *func_name)
+#define FUNC_NAME func_name
+{
+ int result, ret = 0;
+ scm_t_locale c_locale;
+ scm_t_wchar *c_s1, *c_s2;
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
+ SCM_STRING_TO_U32_BUF (s1, c_s1);
+ SCM_STRING_TO_U32_BUF (s2, c_s2);
+
if (c_locale)
+ RUN_IN_LOCALE_SECTION
+ (c_locale,
+ ret = u32_locale_casecoll (func_name,
+ (const scm_t_uint32 *) c_s1,
+ (const scm_t_uint32 *) c_s2,
+ &result));
+ else
+ ret = u32_locale_casecoll (func_name,
+ (const scm_t_uint32 *) c_s1,
+ (const scm_t_uint32 *) c_s2,
+ &result);
+
+ if (SCM_UNLIKELY (ret != 0))
{
-#ifdef USE_GNU_LOCALE_API
- result = strcoll_l (c_s1, c_s2, c_locale);
-#else
-#ifdef HAVE_STRCOLL
- RUN_IN_LOCALE_SECTION (c_locale, result = strcoll (c_s1, c_s2));
-#else
- result = strcmp (c_s1, c_s2);
-#endif
-#endif /* !USE_GNU_LOCALE_API */
+ errno = ret;
+ scm_syserror (FUNC_NAME);
}
- else
-#ifdef HAVE_STRCOLL
- result = strcoll (c_s1, c_s2);
-#else
- result = strcmp (c_s1, c_s2);
-#endif
+ scm_remember_upto_here_2 (s1, s2);
+ scm_remember_upto_here (locale);
return result;
}
#endif
-/* Compare null-terminated strings C_S1 and C_S2 in a case-independent way
- according to LOCALE. Return an integer whose sign is the same as the
- difference between C_S1 and C_S2. */
-static inline int
-compare_strings_ci (const char *c_s1, const char *c_s2, SCM locale,
- const char *func_name)
-#define FUNC_NAME func_name
-{
- int result;
- scm_t_locale c_locale;
- char *c_us1, *c_us2;
-
- SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
-
- c_us1 = (char *) alloca (strlen (c_s1) + 1);
- c_us2 = (char *) alloca (strlen (c_s2) + 1);
-
- if (c_locale)
- {
-#ifdef USE_GNU_LOCALE_API
- str_upcase_l (c_us1, c_s1, c_locale);
- str_upcase_l (c_us2, c_s2, c_locale);
-
- result = strcoll_l (c_us1, c_us2, c_locale);
-#else
- int err;
- scm_t_locale_settings prev_locale;
-
- err = enter_locale_section (c_locale, &prev_locale);
- if (err)
- {
- scm_locale_error (func_name, err);
- return 0;
- }
-
- str_upcase (c_us1, c_s1);
- str_upcase (c_us2, c_s2);
-
-#ifdef HAVE_STRCOLL
- result = strcoll (c_us1, c_us2);
-#else
- result = strcmp (c_us1, c_us2);
-#endif /* !HAVE_STRCOLL */
-
- leave_locale_section (&prev_locale);
- free_locale_settings (&prev_locale);
-#endif /* !USE_GNU_LOCALE_API */
- }
- else
- {
- str_upcase (c_us1, c_s1);
- str_upcase (c_us2, c_s2);
-
-#ifdef HAVE_STRCOLL
- result = strcoll (c_us1, c_us2);
-#else
- result = strcmp (c_us1, c_us2);
-#endif
- }
-
- return result;
-}
-#undef FUNC_NAME
-
-
SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
(SCM s1, SCM s2, SCM locale),
"Compare strings @var{s1} and @var{s2} in a locale-dependent way."
#define FUNC_NAME s_scm_string_locale_lt
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result < 0);
}
#define FUNC_NAME s_scm_string_locale_gt
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result > 0);
}
#define FUNC_NAME s_scm_string_locale_ci_lt
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result < 0);
}
#define FUNC_NAME s_scm_string_locale_ci_gt
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result > 0);
}
#define FUNC_NAME s_scm_string_locale_ci_eq
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result == 0);
}
"according to @var{locale} or to the current locale.")
#define FUNC_NAME s_scm_char_locale_lt
{
- char c_c1[2], c_c2[2];
+ int result;
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+ result = compare_u32_strings (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
- return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) < 0);
+ return scm_from_bool (result < 0);
}
#undef FUNC_NAME
"according to @var{locale} or to the current locale.")
#define FUNC_NAME s_scm_char_locale_gt
{
- char c_c1[2], c_c2[2];
+ int result;
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+ result = compare_u32_strings (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
- return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) > 0);
+ return scm_from_bool (result > 0);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_char_locale_ci_lt
{
int result;
- char c_c1[2], c_c2[2];
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
-
- result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+ result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
return scm_from_bool (result < 0);
}
#define FUNC_NAME s_scm_char_locale_ci_gt
{
int result;
- char c_c1[2], c_c2[2];
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
-
- result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+ result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
return scm_from_bool (result > 0);
}
#define FUNC_NAME s_scm_char_locale_ci_eq
{
int result;
- char c_c1[2], c_c2[2];
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
-
- result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+ result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
return scm_from_bool (result == 0);
}
\f
/* Locale-dependent alphabetic character mapping. */
+static inline int
+u32_locale_tocase (const scm_t_uint32 *c_s1, size_t len,
+ scm_t_uint32 **p_c_s2, size_t * p_len2,
+ scm_t_uint32 *(*func) (const scm_t_uint32 *, size_t,
+ const char *, uninorm_t,
+ scm_t_uint32 *, size_t *))
+{
+ /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must not
+ make any non-local exit. */
+
+ scm_t_uint32 *ret;
+ const char *loc = locale_language ();
+
+ /* The first NULL here indicates that no NFC or NFKC normalization
+ is done. The second NULL means the return buffer is
+ malloc'ed here. */
+ ret = func (c_s1, len, loc, NULL, NULL, p_len2);
+
+ if (ret == NULL)
+ {
+ *p_c_s2 = (scm_t_uint32 *) NULL;
+ *p_len2 = 0;
+ return errno;
+ }
+ *p_c_s2 = ret;
+
+ return 0;
+}
+
+
+
SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
(SCM chr, SCM locale),
"Return the lowercase character that corresponds to @var{chr} "
"according to either @var{locale} or the current locale.")
#define FUNC_NAME s_scm_char_locale_downcase
{
- char c_chr;
- int c_result;
+ int ret;
scm_t_locale c_locale;
+ scm_t_wchar *buf;
+ scm_t_uint32 *downbuf;
+ size_t downlen;
+ SCM str, downchar;
SCM_VALIDATE_CHAR (1, chr);
- c_chr = SCM_CHAR (chr);
-
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+ str = scm_i_make_wide_string (1, &buf);
+ buf[0] = SCM_CHAR (chr);
+
if (c_locale != NULL)
+ RUN_IN_LOCALE_SECTION (c_locale, ret =
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1,
+ &downbuf,
+ &downlen, u32_tolower));
+ else
+ ret =
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1, &downbuf,
+ &downlen, u32_tolower);
+
+ if (SCM_UNLIKELY (ret != 0))
{
-#ifdef USE_GNU_LOCALE_API
- c_result = tolower_l ((int) c_chr, c_locale);
-#else
- RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower ((int) c_chr));
-#endif
+ errno = ret;
+ scm_syserror (FUNC_NAME);
}
+
+ if (downlen == 1)
+ downchar = SCM_MAKE_CHAR ((scm_t_wchar) downbuf[0]);
else
- c_result = tolower ((int) c_chr);
+ downchar = chr;
+ free (downbuf);
- return (SCM_MAKE_CHAR (c_result));
+ return downchar;
}
#undef FUNC_NAME
"according to either @var{locale} or the current locale.")
#define FUNC_NAME s_scm_char_locale_upcase
{
- char c_chr;
- int c_result;
+ int ret;
scm_t_locale c_locale;
+ scm_t_wchar *buf;
+ scm_t_uint32 *upbuf;
+ size_t uplen;
+ SCM str, upchar;
SCM_VALIDATE_CHAR (1, chr);
- c_chr = SCM_CHAR (chr);
-
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+ str = scm_i_make_wide_string (1, &buf);
+ buf[0] = SCM_CHAR (chr);
+
if (c_locale != NULL)
+ RUN_IN_LOCALE_SECTION (c_locale, ret =
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1,
+ &upbuf,
+ &uplen, u32_toupper));
+ else
+ ret =
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1, &upbuf,
+ &uplen, u32_toupper);
+
+ if (SCM_UNLIKELY (ret != 0))
{
-#ifdef USE_GNU_LOCALE_API
- c_result = toupper_l ((int) c_chr, c_locale);
-#else
- RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper ((int) c_chr));
-#endif
+ errno = ret;
+ scm_syserror (FUNC_NAME);
}
+ if (uplen == 1)
+ upchar = SCM_MAKE_CHAR ((scm_t_wchar) upbuf[0]);
else
- c_result = toupper ((int) c_chr);
-
- return (SCM_MAKE_CHAR (c_result));
+ upchar = chr;
+ free (upbuf);
+ return upchar;
}
#undef FUNC_NAME
"locale.")
#define FUNC_NAME s_scm_string_locale_upcase
{
- const char *c_str;
- char *c_ustr;
+ scm_t_wchar *c_str, *c_buf;
+ scm_t_uint32 *c_upstr;
+ size_t len, uplen;
+ int ret;
scm_t_locale c_locale;
+ SCM upstr;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
-
- c_str = scm_i_string_chars (str);
- c_ustr = (char *) alloca (strlen (c_str) + 1);
+ len = scm_i_string_length (str);
+ if (len == 0)
+ return scm_nullstr;
+ SCM_STRING_TO_U32_BUF (str, c_str);
if (c_locale)
- {
-#ifdef USE_GNU_LOCALE_API
- str_upcase_l (c_ustr, c_str, c_locale);
-#else
- RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str));
-#endif
- }
+ RUN_IN_LOCALE_SECTION (c_locale, ret =
+ u32_locale_tocase ((scm_t_uint32 *) c_str, len,
+ &c_upstr,
+ &uplen, u32_toupper));
else
- str_upcase (c_ustr, c_str);
+ ret =
+ u32_locale_tocase ((scm_t_uint32 *) c_str, len,
+ &c_upstr, &uplen, u32_toupper);
scm_remember_upto_here (str);
- return (scm_from_locale_string (c_ustr));
+ if (SCM_UNLIKELY (ret != 0))
+ {
+ errno = ret;
+ scm_syserror (FUNC_NAME);
+ }
+
+ upstr = scm_i_make_wide_string (uplen, &c_buf);
+ memcpy (c_buf, c_upstr, uplen * sizeof (scm_t_wchar));
+ free (c_upstr);
+
+ scm_i_try_narrow_string (upstr);
+
+ return upstr;
}
#undef FUNC_NAME
"locale.")
#define FUNC_NAME s_scm_string_locale_downcase
{
- const char *c_str;
- char *c_lstr;
+ scm_t_wchar *c_str, *c_buf;
+ scm_t_uint32 *c_downstr;
+ size_t len, downlen;
+ int ret;
scm_t_locale c_locale;
+ SCM downstr;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
-
- c_str = scm_i_string_chars (str);
- c_lstr = (char *) alloca (strlen (c_str) + 1);
+ len = scm_i_string_length (str);
+ if (len == 0)
+ return scm_nullstr;
+ SCM_STRING_TO_U32_BUF (str, c_str);
if (c_locale)
- {
-#ifdef USE_GNU_LOCALE_API
- str_downcase_l (c_lstr, c_str, c_locale);
-#else
- RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str));
-#endif
- }
+ RUN_IN_LOCALE_SECTION (c_locale, ret =
+ u32_locale_tocase ((scm_t_uint32 *) c_str, len,
+ &c_downstr,
+ &downlen, u32_tolower));
else
- str_downcase (c_lstr, c_str);
+ ret =
+ u32_locale_tocase ((scm_t_uint32 *) c_str, len,
+ &c_downstr, &downlen, u32_tolower);
scm_remember_upto_here (str);
- return (scm_from_locale_string (c_lstr));
+ if (SCM_UNLIKELY (ret != 0))
+ {
+ errno = ret;
+ scm_syserror (FUNC_NAME);
+ }
+
+ downstr = scm_i_make_wide_string (downlen, &c_buf);
+ memcpy (c_buf, c_downstr, downlen * sizeof (scm_t_wchar));
+ free (c_downstr);
+
+ scm_i_try_narrow_string (downstr);
+
+ return downstr;
}
#undef FUNC_NAME
2. `nl_langinfo ()' is not available on Windows.
3. `nl_langinfo ()' may return strings encoded in a locale different from
- the current one, thereby defeating `scm_from_locale_string ()'.
- Example: support the current locale is "Latin-1" and one asks:
+ the current one.
+ For example:
(nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
- The result will be a UTF-8 string. However, `scm_from_locale_string',
- which expects a Latin-1 string, won't be able to make much sense of the
- returned string. Thus, we'd need an `scm_from_string ()' variant where
- the locale (or charset) is explicitly passed. */
+ returns a result that is a UTF-8 string, regardless of the
+ setting of the current locale. If nl_langinfo supports CODESET,
+ we can convert the string properly using scm_from_stringn. If
+ CODESET is not supported, we won't be able to make much sense of
+ the returned string. */
SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
nl_item c_item;
char *c_result;
scm_t_locale c_locale;
+#ifdef HAVE_LANGINFO_CODESET
+ char *codeset;
+#endif
SCM_VALIDATE_INT_COPY (2, item, c_item);
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
{
#ifdef USE_GNU_LOCALE_API
c_result = nl_langinfo_l (c_item, c_locale);
-#else
+#ifdef HAVE_LANGINFO_CODESET
+ codeset = nl_langinfo_l (CODESET, c_locale);
+#endif /* HAVE_LANGINFO_CODESET */
+#else /* !USE_GNU_LOCALE_API */
/* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
mutex is already taken. */
int lsec_err;
else
{
c_result = nl_langinfo (c_item);
+#ifdef HAVE_LANGINFO_CODESET
+ codeset = nl_langinfo (CODESET);
+#endif /* HAVE_LANGINFO_CODESET */
restore_locale_settings (&lsec_prev_locale);
free_locale_settings (&lsec_prev_locale);
#endif
}
else
- c_result = nl_langinfo (c_item);
+ {
+ c_result = nl_langinfo (c_item);
+#ifdef HAVE_LANGINFO_CODESET
+ codeset = nl_langinfo (CODESET);
+#endif /* HAVE_LANGINFO_CODESET */
+ }
c_result = strdup (c_result);
scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
#endif
default:
- /* FIXME: `locale_string ()' is not appropriate here because of
- encoding issues (see comment above). */
- result = scm_take_locale_string (c_result);
+#ifdef HAVE_LANGINFO_CODESET
+ result = scm_from_stringn (c_result, strlen (c_result),
+ codeset,
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
+#else /* !HAVE_LANGINFO_CODESET */
+ /* This may be incorrectly encoded if the locale differs
+ from the c_locale. */
+ result = scm_from_locale_string (c_result);
+#endif /* !HAVE_LANGINFO_CODESET */
+ free (c_result);
}
}
#include "libguile/i18n.x"
-#ifndef USE_GNU_LOCALE_API
- scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark);
-#endif
-
/* Initialize the global locale object with a special `locale' SMOB. */
+ /* XXX: We don't define it as `LC_GLOBAL_LOCALE' because of bugs as of
+ glibc <= 2.11 not (yet) worked around by Gnulib. See
+ http://sourceware.org/bugzilla/show_bug.cgi?id=11009 for details. */
SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL);
SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
}
+void
+scm_bootstrap_i18n ()
+{
+ scm_c_register_extension ("libguile", "scm_init_i18n",
+ (scm_t_extension_init_func) scm_init_i18n,
+ NULL);
+
+}
+
/*
Local Variables:
#ifndef SCM_I18N_H
#define SCM_I18N_H
-/* Copyright (C) 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009 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
SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale);
SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale);
SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale);
-SCM_API SCM scm_nl_langinfo (SCM item, SCM locale);
-SCM_API void scm_init_i18n (void);
+SCM_INTERNAL SCM scm_nl_langinfo (SCM item, SCM locale);
+
+SCM_INTERNAL void scm_init_i18n (void);
+SCM_INTERNAL void scm_bootstrap_i18n (void);
+
#endif /* SCM_I18N_H */
+++ /dev/null
-/*
- * Copyright (c) 1983, 1990, 1993
- * The Regents of the University of California. All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- * 3. All advertising materials mentioning features or use of this software
- * must display the following acknowledgement:
- * This product includes software developed by the University of
- * California, Berkeley and its contributors.
- * 4. Neither the name of the University nor the names of its contributors
- * may be used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- * SUCH DAMAGE.
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#if defined(LIBC_SCCS) && !defined(lint)
-static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93";
-#endif /* LIBC_SCCS and not lint */
-
-#include <ctype.h>
-
-#ifdef __MINGW32__
-/* Include for MinGW only. Cygwin will have the latter. */
-#include <winsock2.h>
-#else
-#include <sys/param.h>
-#include <netinet/in.h>
-#include <arpa/inet.h>
-#endif
-
-#if 0
-
-/*
- * Ascii internet address interpretation routine.
- * The value returned is in network order.
- */
-u_long
-inet_addr(const char *cp)
-{
- struct in_addr val;
-
- if (inet_aton(cp, &val))
- return (val.s_addr);
- return (INADDR_NONE);
-}
-
-#endif
-
-/* We provide this prototype to avoid compiler warnings. If this ever
- conflicts with a declaration in a system header file, we'll find
- out, because we should include that header file here. */
-int inet_aton (const char *cp, struct in_addr *addr);
-
-/*
- * Check whether "cp" is a valid ascii representation
- * of an Internet address and convert to a binary address.
- * Returns 1 if the address is valid, 0 if not.
- * This replaces inet_addr, the return value from which
- * cannot distinguish between failure and a local broadcast address. */
-int
-inet_aton(const char *cp_arg, struct in_addr *addr)
-{
- register unsigned long val;
- register int base, n;
- register unsigned char c;
- register unsigned const char *cp = (unsigned const char *) cp_arg;
- unsigned int parts[4];
- register unsigned int *pp = parts;
-
- for (;;) {
- /*
- * Collect number up to ``.''.
- * Values are specified as for C:
- * 0x=hex, 0=octal, other=decimal.
- */
- val = 0; base = 10;
- if (*cp == '0') {
- if (*++cp == 'x' || *cp == 'X')
- base = 16, cp++;
- else
- base = 8;
- }
- while ((c = *cp) != '\0') {
- if (isascii(c) && isdigit(c)) {
- val = (val * base) + (c - '0');
- cp++;
- continue;
- }
- if (base == 16 && isascii(c) && isxdigit(c)) {
- val = (val << 4) +
- (c + 10 - (islower(c) ? 'a' : 'A'));
- cp++;
- continue;
- }
- break;
- }
- if (*cp == '.') {
- /*
- * Internet format:
- * a.b.c.d
- * a.b.c (with c treated as 16-bits)
- * a.b (with b treated as 24 bits)
- */
- if (pp >= parts + 3 || val > 0xff)
- return (0);
- *pp++ = val, cp++;
- } else
- break;
- }
- /*
- * Check for trailing characters.
- */
- if (*cp && (!isascii(*cp) || !isspace(*cp)))
- return (0);
- /*
- * Concoct the address according to
- * the number of parts specified.
- */
- n = pp - parts + 1;
- switch (n) {
-
- case 1: /* a -- 32 bits */
- break;
-
- case 2: /* a.b -- 8.24 bits */
- if (val > 0xffffff)
- return (0);
- val |= parts[0] << 24;
- break;
-
- case 3: /* a.b.c -- 8.8.16 bits */
- if (val > 0xffff)
- return (0);
- val |= (parts[0] << 24) | (parts[1] << 16);
- break;
-
- case 4: /* a.b.c.d -- 8.8.8.8 bits */
- if (val > 0xff)
- return (0);
- val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
- break;
- }
- if (addr)
- addr->s_addr = htonl(val);
- return (1);
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
#include "libguile/deprecation.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
-#if 0
-#include "libguile/environments.h"
-#endif
#include "libguile/eq.h"
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
-#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
#include "libguile/hashtab.h"
#include "libguile/hooks.h"
#include "libguile/gettext.h"
+#include "libguile/i18n.h"
#include "libguile/iselect.h"
#include "libguile/ioext.h"
#include "libguile/keywords.h"
#include "libguile/load.h"
#include "libguile/macros.h"
#include "libguile/mallocs.h"
+#include "libguile/memoize.h"
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
-#include "libguile/objects.h"
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/procs.h"
+#include "libguile/promises.h"
#include "libguile/properties.h"
#include "libguile/array-map.h"
#include "libguile/random.h"
#include "libguile/symbols.h"
#include "libguile/throw.h"
#include "libguile/arrays.h"
+#include "libguile/trees.h"
#include "libguile/values.h"
#include "libguile/variable.h"
#include "libguile/vectors.h"
}
scm_storage_prehistory ();
- scm_threads_prehistory (base);
- scm_ports_prehistory ();
- scm_smob_prehistory ();
- scm_fluids_prehistory ();
- scm_hashtab_prehistory (); /* requires storage_prehistory */
+ scm_threads_prehistory (base); /* requires storage_prehistory */
+ scm_weaks_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
#endif
- if (scm_init_storage ()) /* requires threads_prehistory,
- smob_prehistory and
- hashtab_prehistory */
- abort ();
-
- scm_struct_prehistory (); /* requires storage */
- scm_symbols_prehistory (); /* requires storage */
-#if 0
- scm_environments_prehistory (); /* requires storage */
-#endif
- scm_modules_prehistory (); /* requires storage and hash tables */
- scm_init_variable (); /* all bindings need variables */
- scm_init_continuations ();
+ scm_symbols_prehistory (); /* requires weaks_prehistory */
+ scm_modules_prehistory ();
+ scm_init_array_handle ();
+ scm_init_generalized_arrays ();
+ scm_init_generalized_vectors ();
+ scm_init_strings (); /* Requires array-handle, generalized-vectors */
+ scm_init_struct (); /* Requires strings */
+ scm_smob_prehistory ();
+ scm_init_variable ();
+ scm_init_continuations (); /* requires smob_prehistory */
scm_init_root (); /* requires continuations */
- scm_init_threads (); /* requires fluids */
+ scm_init_threads (); /* requires smob_prehistory */
scm_init_gsubr ();
scm_init_thread_procs (); /* requires gsubrs */
scm_init_procprop ();
-#if 0
- scm_init_environments ();
-#endif
scm_init_alist ();
- scm_init_arbiters ();
- scm_init_async ();
+ scm_init_arbiters (); /* requires smob_prehistory */
+ scm_init_async (); /* requires smob_prehistory */
scm_init_boolean ();
scm_init_chars ();
#ifdef GUILE_DEBUG_MALLOC
scm_init_debug_malloc ();
#endif
- scm_init_dynwind ();
+ scm_init_dynwind (); /* requires smob_prehistory */
scm_init_eq ();
scm_init_error ();
-#if 0
- /* See futures.h for a comment why futures are not enabled.
- */
- scm_init_futures ();
-#endif
scm_init_fluids ();
- scm_init_feature (); /* Requires fluids */
- scm_init_backtrace (); /* Requires fluids */
+ scm_init_feature ();
+ scm_init_backtrace ();
scm_init_fports ();
scm_init_strports ();
scm_init_ports ();
- scm_init_gdbint (); /* Requires strports */
scm_init_hash ();
scm_init_hashtab ();
- scm_init_deprecation (); /* Requires hashtabs */
+ scm_init_deprecation ();
scm_init_objprop ();
+ scm_init_promises (); /* requires smob_prehistory */
scm_init_properties ();
scm_init_hooks (); /* Requires smob_prehistory */
- scm_init_gc (); /* Requires hooks, async */
+ scm_init_gc (); /* Requires hooks */
+ scm_init_gc_protect_object (); /* requires threads_prehistory */
+ scm_init_gdbint (); /* Requires strports, gc_protect_object */
scm_init_gettext ();
scm_init_ioext ();
- scm_init_keywords ();
+ scm_init_keywords (); /* Requires smob_prehistory */
scm_init_list ();
- scm_init_macros ();
- scm_init_mallocs ();
- scm_init_modules ();
+ scm_init_macros (); /* Requires smob_prehistory */
+ scm_init_mallocs (); /* Requires smob_prehistory */
+ scm_init_modules (); /* Requires smob_prehistory */
scm_init_numbers ();
scm_init_options ();
scm_init_pairs ();
#ifdef HAVE_POSIX
- scm_init_filesys ();
+ scm_init_filesys (); /* Requires smob_prehistory */
scm_init_posix ();
#endif
#ifdef HAVE_REGCOMP
- scm_init_regex_posix ();
+ scm_init_regex_posix (); /* Requires smob_prehistory */
#endif
scm_init_procs ();
scm_init_scmsigs ();
scm_init_socket ();
#endif
scm_init_sort ();
- scm_init_srcprop ();
+ scm_init_srcprop (); /* requires smob_prehistory */
scm_init_stackchk ();
- scm_init_array_handle ();
- scm_init_generalized_arrays ();
- scm_init_generalized_vectors ();
- scm_init_vectors ();
+ scm_init_vectors (); /* Requires array-handle, generalized-vectors */
scm_init_uniform ();
- scm_init_bitvectors ();
- scm_bootstrap_bytevectors ();
- scm_init_srfi_4 ();
- scm_init_arrays ();
+ scm_init_bitvectors (); /* Requires smob_prehistory, array-handle, generalized-vectors */
+ scm_bootstrap_bytevectors (); /* Requires smob_prehistory, array-handle, generalized-vectors */
+ scm_init_srfi_4 (); /* Requires smob_prehistory, array-handle, generalized-vectors */
+ scm_init_arrays (); /* Requires smob_prehistory, array-handle */
scm_init_array_map ();
- scm_init_strings (); /* Requires array-handle */
- scm_init_struct (); /* Requires strings */
- scm_init_stacks (); /* Requires strings, struct */
+ scm_bootstrap_vm (); /* requires smob_prehistory, gc_permanent_object */
+
+ scm_init_frames (); /* Requires smob_prehistory */
+ scm_init_stacks (); /* Requires strings, struct, frames */
scm_init_symbols ();
scm_init_values (); /* Requires struct */
scm_init_load (); /* Requires strings */
- scm_init_objects (); /* Requires struct */
- scm_init_print (); /* Requires strings, struct */
+ scm_init_print (); /* Requires strings, struct, smob */
scm_init_read ();
scm_init_stime ();
scm_init_strorder ();
scm_init_srfi_13 ();
- scm_init_srfi_14 ();
- scm_init_throw ();
+ scm_init_srfi_14 (); /* Requires smob_prehistory */
+ scm_init_throw (); /* Requires smob_prehistory */
+ scm_init_trees ();
scm_init_version ();
scm_init_weaks ();
- scm_init_guardians ();
+ scm_init_guardians (); /* requires smob_prehistory */
scm_init_vports ();
- scm_init_eval ();
+ scm_init_standard_ports (); /* Requires fports */
+ scm_init_memoize (); /* Requires smob_prehistory */
+ scm_init_eval (); /* Requires smob_prehistory */
+ scm_init_load_path ();
+ scm_init_eval_in_scheme ();
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */
- scm_init_random ();
+ scm_init_random (); /* Requires smob_prehistory */
scm_init_simpos ();
- scm_init_load_path ();
- scm_init_standard_ports (); /* Requires fports */
- scm_init_dynamic_linking ();
+ scm_init_dynamic_linking (); /* Requires smob_prehistory */
+ scm_bootstrap_i18n ();
#if SCM_ENABLE_ELISP
scm_init_lang ();
#endif /* SCM_ENABLE_ELISP */
scm_init_rw ();
scm_init_extensions ();
- scm_bootstrap_vm ();
-
atexit (cleanup_for_exit);
scm_load_startup_files ();
}
"inline.c", when `inline' is not supported at all or when "extern inline"
is used. */
+#include "libguile/bdw-gc.h"
+
+
SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_API SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr);
+SCM_API SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
+
SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
- SCM z;
- SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist);
+ SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_cell))));
- if (scm_is_null (*freelist))
- z = scm_gc_for_newcell (&scm_i_master_freelist, freelist);
- else
- {
- z = *freelist;
- *freelist = SCM_FREE_CELL_CDR (*freelist);
- }
+ /* Initialize the type slot last so that the cell is ignored by the GC
+ until it is completely initialized. This is only relevant when the GC
+ can actually run during this code, which it can't since the GC only runs
+ when all other threads are stopped. */
+ SCM_GC_SET_CELL_WORD (cell, 1, cdr);
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_debug_cell_accesses_p)
- {
- if (SCM_GC_MARK_P (z))
- {
- fprintf(stderr, "scm_cell tried to allocate a marked cell.\n");
- abort();
- }
- else if (SCM_GC_CELL_WORD(z, 0) != scm_tc_free_cell)
- {
- fprintf(stderr, "cell from freelist is not a free cell.\n");
- abort();
- }
- }
-
-#if (SCM_DEBUG_MARKING_API == 0)
- /*
- Always set mark. Otherwise cells that are alloced before
- scm_debug_cell_accesses_p is toggled seem invalid.
- */
- SCM_SET_GC_MARK (z);
-#endif /* SCM_DEBUG_MARKING_API */
-
- /*
- TODO: figure out if this use of mark bits is valid with
- threading. What if another thread is doing GC at this point
- ... ?
- */
+ return cell;
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+SCM
+scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
+{
+ SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC_STUBBORN (sizeof (scm_t_cell))));
+
+ /* Initialize the type slot last so that the cell is ignored by the GC
+ until it is completely initialized. This is only relevant when the GC
+ can actually run during this code, which it can't since the GC only runs
+ when all other threads are stopped. */
+ SCM_GC_SET_CELL_WORD (cell, 1, cdr);
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
+
+ GC_END_STUBBORN_CHANGE ((void *) cell);
+
+ return cell;
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
#endif
+SCM
+scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ SCM z;
-
+ z = SCM_PACK ((scm_t_bits) (GC_MALLOC (2 * sizeof (scm_t_cell))));
/* Initialize the type slot last so that the cell is ignored by the
GC until it is completely initialized. This is only relevant
when the GC can actually run during this code, which it can't
since the GC only runs when all other threads are stopped.
*/
- SCM_GC_SET_CELL_WORD (z, 1, cdr);
+ SCM_GC_SET_CELL_WORD (z, 1, cbr);
+ SCM_GC_SET_CELL_WORD (z, 2, ccr);
+ SCM_GC_SET_CELL_WORD (z, 3, cdr);
SCM_GC_SET_CELL_WORD (z, 0, car);
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_expensive_debug_cell_accesses_p )
- scm_i_expensive_validation_check (z);
+ /* When this function is inlined, it's possible that the last
+ SCM_GC_SET_CELL_WORD above will be adjacent to a following
+ initialization of z. E.g., it occurred in scm_make_real. GCC
+ from around version 3 (e.g., certainly 3.2) began taking
+ advantage of strict C aliasing rules which say that it's OK to
+ interchange the initialization above and the one below when the
+ pointer types appear to differ sufficiently. We don't want that,
+ of course. GCC allows this behaviour to be disabled with the
+ -fno-strict-aliasing option, but would also need to be supplied
+ by Guile users. Instead, the following statements prevent the
+ reordering.
+ */
+#ifdef __GNUC__
+ __asm__ volatile ("" : : : "memory");
+#else
+ /* portable version, just in case any other compiler does the same
+ thing. */
+ scm_remember_upto_here_1 (z);
#endif
-
+
return z;
}
SCM_C_EXTERN_INLINE
#endif
SCM
-scm_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr)
+scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
{
SCM z;
- SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist2);
-
- if (scm_is_null (*freelist))
- z = scm_gc_for_newcell (&scm_i_master_freelist2, freelist);
- else
- {
- z = *freelist;
- *freelist = SCM_FREE_CELL_CDR (*freelist);
- }
+ z = SCM_PACK ((scm_t_bits) (GC_MALLOC_STUBBORN (2 * sizeof (scm_t_cell))));
/* Initialize the type slot last so that the cell is ignored by the
GC until it is completely initialized. This is only relevant
when the GC can actually run during this code, which it can't
SCM_GC_SET_CELL_WORD (z, 3, cdr);
SCM_GC_SET_CELL_WORD (z, 0, car);
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_debug_cell_accesses_p)
- {
- if (SCM_GC_MARK_P (z))
- {
- fprintf(stderr,
- "scm_double_cell tried to allocate a marked cell.\n");
- abort();
- }
- }
-#if (SCM_DEBUG_MARKING_API == 0)
- /* see above. */
- SCM_SET_GC_MARK (z);
-#endif /* SCM_DEBUG_MARKING_API */
-
-#endif
+ GC_END_STUBBORN_CHANGE ((void *) z);
/* When this function is inlined, it's possible that the last
SCM_GC_SET_CELL_WORD above will be adjacent to a following
SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
- if (SCM_UNLIKELY (p < 0 && -p > h->base))
+ if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
- if (SCM_UNLIKELY (p < 0 && -p > h->base))
+ if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
{
table[i].opcode = i;
if (table[i].name)
- table[i].symname =
- scm_permanent_object (scm_from_locale_symbol (table[i].name));
+ table[i].symname = scm_from_locale_symbol (table[i].name);
else
table[i].symname = SCM_BOOL_F;
}
struct scm_instruction *table = fetch_instruction_table ();
SCM op;
- if (SCM_UNLIKELY (SCM_FALSEP (instructions_by_name)))
- {
- int i;
- instructions_by_name = scm_permanent_object
- (scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS)));
+ if (SCM_UNLIKELY (scm_is_false (instructions_by_name)))
+ {
+ unsigned int i;
+
+ instructions_by_name =
+ scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS));
+
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
if (scm_is_true (table[i].symname))
scm_hashq_set_x (instructions_by_name, table[i].symname,
SCM_I_MAKINUM (i));
}
-
+
op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
if (SCM_I_INUMP (op))
return &table[SCM_I_INUM (op)];
"")
#define FUNC_NAME s_scm_instruction_p
{
- return SCM_BOOL (scm_lookup_instruction_by_name (obj));
+ return scm_from_bool (scm_lookup_instruction_by_name (obj) != NULL);
}
#undef FUNC_NAME
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 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
\f
+static SCM keyword_obarray;
+
scm_t_bits scm_tc16_keyword;
#define KEYWORDP(X) (SCM_SMOB_PREDICATE (scm_tc16_keyword, (X)))
SCM_CRITICAL_SECTION_START;
/* njrev: NEWSMOB and hashq_set_x can raise errors */
- keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F);
+ keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F);
if (scm_is_false (keyword))
{
SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
- scm_hashq_set_x (scm_keyword_obarray, symbol, keyword);
+ scm_hashq_set_x (keyword_obarray, symbol, keyword);
}
SCM_CRITICAL_SECTION_END;
return keyword;
scm_init_keywords ()
{
scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
- scm_set_smob_mark (scm_tc16_keyword, scm_markcdr);
scm_set_smob_print (scm_tc16_keyword, keyword_print);
- scm_keyword_obarray = scm_c_make_hash_table (0);
+ keyword_obarray = scm_c_make_hash_table (0);
#include "libguile/keywords.x"
}
#ifndef SCM_LANG_H
#define SCM_LANG_H
-/* Copyright (C) 1998, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998, 2004, 2006, 2008, 2009 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
#endif /* ! SCM_ENABLE_ELISP */
-#define SCM_NULL_OR_NIL_P(x) (scm_is_null (x) || SCM_NILP (x))
+#define SCM_NULL_OR_NIL_P(x) (scm_is_null_or_nil (x))
#endif /* SCM_LANG_H */
-/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008
+/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
"@end lisp")
#define FUNC_NAME s_scm_filter
{
- scm_t_trampoline_1 call = scm_trampoline_1 (pred);
SCM walk;
SCM *prev;
SCM res = SCM_EOL;
- SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
SCM_VALIDATE_LIST (2, list);
for (prev = &res, walk = list;
scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (scm_is_true (call (pred, SCM_CAR (walk))))
+ if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
{
*prev = scm_cons (SCM_CAR (walk), SCM_EOL);
prev = SCM_CDRLOC (*prev);
"Linear-update variant of @code{filter}.")
#define FUNC_NAME s_scm_filter_x
{
- scm_t_trampoline_1 call = scm_trampoline_1 (pred);
SCM walk;
SCM *prev;
- SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
SCM_VALIDATE_LIST (2, list);
for (prev = &list, walk = list;
scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (scm_is_true (call (pred, SCM_CAR (walk))))
+ if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
prev = SCM_CDRLOC (walk);
else
*prev = SCM_CDR (walk);
#ifndef SCM_LIST_H
#define SCM_LIST_H
-/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2005,2006,2008
+/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2005,2006,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM_API SCM scm_delete1_x (SCM item, SCM lst);
SCM_API SCM scm_filter (SCM pred, SCM list);
SCM_API SCM scm_filter_x (SCM pred, SCM list);
+SCM_API SCM scm_copy_tree (SCM obj);
\f
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2008, 2009 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
/* The current reader (a fluid). */
static SCM the_reader = SCM_BOOL_F;
-static size_t the_reader_fluid_num = 0;
+
SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
(SCM filename),
SCM port = scm_open_file (filename, scm_from_locale_string ("r"));
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_i_dynwind_current_load_port (port);
- encoding = scm_scan_for_encoding (port);
+
+ encoding = scm_i_scan_for_encoding (port);
if (encoding)
- {
- scm_i_set_port_encoding_x (port, encoding);
- free (encoding);
- }
+ scm_i_set_port_encoding_x (port, encoding);
else
- /* The file has no encoding declaraed. We'll presume Latin-1. */
+ /* The file has no encoding declared. We'll presume Latin-1. */
scm_i_set_port_encoding_x (port, NULL);
+
while (1)
{
SCM reader, form;
/* Lookup and use the current reader to read the next
expression. */
- reader = SCM_FAST_FLUID_REF (the_reader_fluid_num);
+ reader = scm_fluid_ref (the_reader);
if (reader == SCM_BOOL_F)
form = scm_read (port);
else
If FILENAME is absolute, return it unchanged.
If given, EXTENSIONS is a list of strings; for each directory
in PATH, we search for FILENAME concatenated with each EXTENSION. */
-SCM_DEFINE (scm_search_path, "search-path", 2, 2, 0,
- (SCM path, SCM filename, SCM extensions, SCM require_exts),
+SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
+ (SCM path, SCM filename, SCM rest),
"Search @var{path} for a directory containing a file named\n"
"@var{filename}. The file must be readable, and not a directory.\n"
"If we find one, return its full filename; otherwise, return\n"
struct stringbuf buf;
char *filename_chars;
size_t filename_len;
+ SCM extensions, require_exts;
SCM result = SCM_BOOL_F;
+ if (scm_is_null (rest))
+ {
+ /* Called either by Scheme code that didn't provide the optional
+ arguments, or C code that used the Guile 1.8 signature (2 required,
+ 1 optional arg) and passed '() as the EXTENSIONS argument. */
+ extensions = SCM_EOL;
+ require_exts = SCM_UNDEFINED;
+ }
+ else
+ {
+ if (scm_is_null (SCM_CAR (rest)) || scm_is_pair (SCM_CAR (rest)))
+ {
+ /* Called by Scheme code written for 1.9. */
+ extensions = SCM_CAR (rest);
+ if (scm_is_null (SCM_CDR (rest)))
+ require_exts = SCM_UNDEFINED;
+ else
+ {
+ require_exts = SCM_CADR (rest);
+ if (SCM_UNLIKELY (!scm_is_null (SCM_CDDR (rest))))
+ scm_wrong_num_args (scm_from_locale_string (FUNC_NAME));
+ }
+ }
+ else
+ {
+ /* Called by C code that uses the 1.8 signature, i.e., which
+ expects the 3rd argument to be EXTENSIONS. */
+ extensions = rest;
+ require_exts = SCM_UNDEFINED;
+ }
+ }
+
if (SCM_UNBNDP (extensions))
extensions = SCM_EOL;
+ SCM_VALIDATE_LIST (3, extensions);
+
if (SCM_UNBNDP (require_exts))
require_exts = SCM_BOOL_F;
SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL);
if (scm_ilength (exts) < 0)
SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL);
- return scm_search_path (path, filename, exts, SCM_UNDEFINED);
+ return scm_search_path (path, filename, exts);
}
#undef FUNC_NAME
return res;
}
+SCM_KEYWORD (kw_env, "env");
+
static SCM
do_try_autocompile (void *data)
{
if (scm_is_true (compile_file))
{
- SCM res = scm_call_1 (scm_variable_ref (compile_file), source);
+ /* Auto-compile in the context of the current module. */
+ SCM res = scm_call_3 (scm_variable_ref (compile_file), source,
+ kw_env, scm_current_module ());
scm_puts (";;; compiled ", scm_current_error_port ());
scm_display (res, scm_current_error_port ());
scm_newline (scm_current_error_port ());
SCM_DEFINE (scm_sys_warn_autocompilation_enabled, "%warn-autocompilation-enabled", 0, 0, 0,
(void), "")
+#define FUNC_NAME s_scm_sys_warn_autocompilation_enabled
{
static int message_shown = 0;
-
+
if (!message_shown)
{
scm_puts (";;; note: autocompilation is enabled, set GUILE_AUTO_COMPILE=0\n"
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-
static SCM
scm_try_autocompile (SCM source)
{
NULL, NULL);
}
-SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
- (SCM filename, SCM exception_on_not_found),
+SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
+ (SCM args),
"Search @var{%load-path} for the file named @var{filename} and\n"
"load it into the top-level environment. If @var{filename} is a\n"
"relative pathname and is not found in the list of search paths,\n"
"@code{#f} is returned instead.")
#define FUNC_NAME s_scm_primitive_load_path
{
+ SCM filename, exception_on_not_found;
SCM full_filename, compiled_filename;
int compiled_is_fallback = 0;
+ if (scm_is_string (args))
+ {
+ /* C code written for 1.8 and earlier expects this function to take a
+ single argument (the file name). */
+ filename = args;
+ exception_on_not_found = SCM_UNDEFINED;
+ }
+ else
+ {
+ /* Starting from 1.9, this function takes 1 required and 1 optional
+ argument. */
+ long len;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, args, len);
+ if (len < 1 || len > 2)
+ scm_error_num_args_subr (FUNC_NAME);
+
+ filename = SCM_CAR (args);
+ SCM_VALIDATE_STRING (SCM_ARG1, filename);
+
+ exception_on_not_found = len > 1 ? SCM_CADR (args) : SCM_UNDEFINED;
+ }
+
if (SCM_UNBNDP (exception_on_not_found))
exception_on_not_found = SCM_BOOL_T;
full_filename = scm_sys_search_load_path (filename);
- compiled_filename = scm_search_path (*scm_loc_load_compiled_path,
- filename,
- *scm_loc_load_compiled_extensions,
- SCM_BOOL_T);
-
+ compiled_filename =
+ scm_search_path (*scm_loc_load_compiled_path,
+ filename,
+ scm_list_2 (*scm_loc_load_compiled_extensions,
+ SCM_BOOL_T));
+
if (scm_is_false (compiled_filename)
&& scm_is_true (full_filename)
&& scm_is_true (*scm_loc_compile_fallback_path)
scm_puts (";;; found fresh local cache at ", scm_current_error_port ());
scm_display (fallback, scm_current_error_port ());
scm_newline (scm_current_error_port ());
- return scm_load_compiled_with_vm (compiled_filename);
+ return scm_load_compiled_with_vm (fallback);
}
}
SCM
scm_c_primitive_load_path (const char *filename)
{
- return scm_primitive_load_path (scm_from_locale_string (filename),
- SCM_BOOL_T);
+ return scm_primitive_load_path (scm_from_locale_string (filename));
+}
+
+void
+scm_init_eval_in_scheme (void)
+{
+ SCM eval_scm, eval_go;
+ eval_scm = scm_search_path (*scm_loc_load_path,
+ scm_from_locale_string ("ice-9/eval.scm"),
+ SCM_EOL);
+ eval_go = scm_search_path (*scm_loc_load_compiled_path,
+ scm_from_locale_string ("ice-9/eval.go"),
+ SCM_EOL);
+
+ if (scm_is_true (eval_scm) && scm_is_true (eval_go)
+ && compiled_is_fresh (eval_scm, eval_go))
+ scm_load_compiled_with_vm (eval_go);
+ else
+ /* if we have no eval.go, we shouldn't load any compiled code at all */
+ *scm_loc_load_compiled_path = SCM_EOL;
}
\f
/* Information about the build environment. */
+SCM_VARIABLE_INIT (sys_host_type, "%host-type",
+ scm_from_locale_string (HOST_TYPE));
+
+
/* Initialize the scheme variable %guile-build-info, based on data
provided by the Makefile, via libpath.h. */
static void
void
scm_init_load ()
{
- scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr));
+ scm_listofnullstr = scm_list_1 (scm_nullstr);
scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL));
scm_loc_load_extensions
= SCM_VARIABLE_LOC (scm_c_define ("%load-extensions",
= SCM_VARIABLE_LOC (scm_c_define ("%load-should-autocompile", SCM_BOOL_F));
the_reader = scm_make_fluid ();
- the_reader_fluid_num = SCM_FLUID_NUM (the_reader);
- SCM_FAST_FLUID_SET_X (the_reader_fluid_num, SCM_BOOL_F);
+ scm_fluid_set_x (the_reader, SCM_BOOL_F);
scm_c_define("current-reader", the_reader);
init_build_info ();
#ifndef SCM_LOAD_H
#define SCM_LOAD_H
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 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
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_search_path (SCM path, SCM filename, SCM exts, SCM require_exts);
+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, SCM exception_on_not_found);
+SCM_API SCM scm_primitive_load_path (SCM filename_and_exception_on_not_found);
SCM_API SCM scm_c_primitive_load_path (const char *filename);
SCM_INTERNAL SCM scm_sys_warn_autocompilation_enabled (void);
SCM_INTERNAL void scm_init_load_path (void);
SCM_INTERNAL void scm_init_load (void);
+SCM_INTERNAL void scm_init_eval_in_scheme (void);
#endif /* SCM_LOAD_H */
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009 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
# include <config.h>
#endif
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include "libguile/_scm.h"
#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */
#include "libguile/eval.h"
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
SCM code = SCM_MACRO_CODE (macro);
- if (!SCM_CLOSUREP (code)
- || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
- || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
- macro, port, pstate)))
- {
- scm_puts ("#<", port);
- if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
- scm_puts ("extended-", port);
+ scm_puts ("#<", port);
- if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
- scm_puts ("primitive-", port);
+ if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
+ scm_puts ("extended-", port);
- if (SCM_MACRO_TYPE (macro) == 0)
- scm_puts ("syntax", port);
+ /* FIXME: doesn't catch boot closures; but do we care? */
+ if (!SCM_PROGRAM_P (code))
+ scm_puts ("primitive-", port);
+
+ if (SCM_MACRO_TYPE (macro) == 0)
+ scm_puts ("syntax", port);
#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_MACRO_TYPE (macro) == 1)
- scm_puts ("macro", port);
+ if (SCM_MACRO_TYPE (macro) == 1)
+ scm_puts ("macro", port);
#endif
- if (SCM_MACRO_TYPE (macro) == 2)
- scm_puts ("macro!", port);
- if (SCM_MACRO_TYPE (macro) == 3)
- scm_puts ("builtin-macro!", port);
- if (SCM_MACRO_TYPE (macro) == 4)
- scm_puts ("syncase-macro", port);
+ if (SCM_MACRO_TYPE (macro) == 2)
+ scm_puts ("macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 3)
+ scm_puts ("builtin-macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 4)
+ scm_puts ("syncase-macro", port);
+
+ scm_putc (' ', port);
+ scm_iprin1 (scm_macro_name (macro), port, pstate);
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ {
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_2 (macro), port);
scm_putc (' ', port);
- scm_iprin1 (scm_macro_name (macro), port, pstate);
-
- if (SCM_CLOSUREP (code) && SCM_PRINT_SOURCE_P)
- {
- SCM formals = SCM_CLOSURE_FORMALS (code);
- SCM env = SCM_ENV (code);
- SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
- SCM src = scm_i_unmemocopy_body (SCM_CODE (code), xenv);
- scm_putc (' ', port);
- scm_iprin1 (src, port, pstate);
- }
-
- if (SCM_MACRO_IS_EXTENDED (macro))
- {
- scm_putc (' ', port);
- scm_write (SCM_SMOB_OBJECT_2 (macro), port);
- scm_putc (' ', port);
- scm_write (SCM_SMOB_OBJECT_3 (macro), port);
- }
-
- scm_putc ('>', port);
+ scm_write (SCM_SMOB_OBJECT_3 (macro), port);
}
- return 1;
-}
+ scm_putc ('>', port);
-static SCM
-macro_mark (SCM macro)
-{
- if (SCM_MACRO_IS_EXTENDED (macro))
- { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro));
- scm_gc_mark (SCM_SMOB_OBJECT_3 (macro));
- }
- return SCM_SMOB_OBJECT (macro);
+ return 1;
}
static SCM
SCM_VALIDATE_SMOB (1, m, macro);
data = SCM_PACK (SCM_SMOB_DATA (m));
- if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data))
+ if (scm_is_true (scm_procedure_p (data)))
return data;
else
return SCM_BOOL_F;
scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
{
SCM var = scm_c_define (name, SCM_UNDEFINED);
- SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
+ SCM transformer = scm_c_make_gsubr (name, 2, 0, 0, fcn);
SCM_VARIABLE_SET (var, macroizer (transformer));
return SCM_UNSPECIFIED;
}
scm_init_macros ()
{
scm_tc16_macro = scm_make_smob_type ("macro", 0);
- scm_set_smob_mark (scm_tc16_macro, macro_mark);
scm_set_smob_print (scm_tc16_macro, macro_print);
#include "libguile/macros.x"
}
#ifndef SCM_MACROS_H
#define SCM_MACROS_H
-/* Copyright (C) 1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003, 2006, 2008, 2009 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
SCM_INTERNAL void scm_init_macros (void);
#if SCM_ENABLE_DEPRECATED == 1
-SCM_API SCM scm_makmacro (SCM code);
+SCM_DEPRECATED SCM scm_makmacro (SCM code);
#endif
#endif /* SCM_MACROS_H */
scm_t_bits scm_tc16_malloc;
-static size_t
-malloc_free (SCM ptr)
-{
- if (SCM_MALLOCDATA (ptr))
- free (SCM_MALLOCDATA (ptr));
- return 0;
-}
-
static int
malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
\f
-void
+void
scm_init_mallocs ()
{
scm_tc16_malloc = scm_make_smob_type ("malloc", 0);
- scm_set_smob_free (scm_tc16_malloc, malloc_free);
scm_set_smob_print (scm_tc16_malloc, malloc_print);
}
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+ * 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
+ */
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/__scm.h"
+
+#include <assert.h>
+#include "libguile/_scm.h"
+#include "libguile/continuations.h"
+#include "libguile/eq.h"
+#include "libguile/list.h"
+#include "libguile/macros.h"
+#include "libguile/memoize.h"
+#include "libguile/modules.h"
+#include "libguile/srcprop.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/strings.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
+
+
+\f
+
+
+#if 0
+#define CAR(x) SCM_CAR(x)
+#define CDR(x) SCM_CDR(x)
+#define CAAR(x) SCM_CAAR(x)
+#define CADR(x) SCM_CADR(x)
+#define CDAR(x) SCM_CDAR(x)
+#define CDDR(x) SCM_CDDR(x)
+#define CADDR(x) SCM_CADDR(x)
+#define CDDDR(x) SCM_CDDDR(x)
+#define CADDDR(x) SCM_CDDDR(x)
+#else
+#define CAR(x) scm_car(x)
+#define CDR(x) scm_cdr(x)
+#define CAAR(x) scm_caar(x)
+#define CADR(x) scm_cadr(x)
+#define CDAR(x) scm_cdar(x)
+#define CDDR(x) scm_cddr(x)
+#define CADDR(x) scm_caddr(x)
+#define CDDDR(x) scm_cdddr(x)
+#define CADDDR(x) scm_cadddr(x)
+#endif
+
+
+static const char s_bad_expression[] = "Bad expression";
+static const char s_expression[] = "Missing or extra expression in";
+static const char s_missing_expression[] = "Missing expression in";
+static const char s_extra_expression[] = "Extra expression in";
+static const char s_empty_combination[] = "Illegal empty combination";
+static const char s_missing_body_expression[] = "Missing body expression in";
+static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
+static const char s_bad_define[] = "Bad define placement";
+static const char s_missing_clauses[] = "Missing clauses";
+static const char s_misplaced_else_clause[] = "Misplaced else clause";
+static const char s_bad_case_clause[] = "Bad case clause";
+static const char s_bad_case_labels[] = "Bad case labels";
+static const char s_duplicate_case_label[] = "Duplicate case label";
+static const char s_bad_cond_clause[] = "Bad cond clause";
+static const char s_missing_recipient[] = "Missing recipient in";
+static const char s_bad_variable[] = "Bad variable";
+static const char s_bad_bindings[] = "Bad bindings";
+static const char s_bad_binding[] = "Bad binding";
+static const char s_duplicate_binding[] = "Duplicate binding";
+static const char s_bad_exit_clause[] = "Bad exit clause";
+static const char s_bad_formals[] = "Bad formals";
+static const char s_bad_formal[] = "Bad formal";
+static const char s_duplicate_formal[] = "Duplicate formal";
+static const char s_splicing[] = "Non-list result for unquote-splicing";
+static const char s_bad_slot_number[] = "Bad slot number";
+
+
+/* Signal a syntax error. We distinguish between the form that caused the
+ * error and the enclosing expression. The error message will print out as
+ * shown in the following pattern. The file name and line number are only
+ * given when they can be determined from the erroneous form or from the
+ * enclosing expression.
+ *
+ * <filename>: In procedure memoization:
+ * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
+
+SCM_SYMBOL (syntax_error_key, "syntax-error");
+
+/* The prototype is needed to indicate that the function does not return. */
+static void
+syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
+
+static void
+syntax_error (const char* const msg, const SCM form, const SCM expr)
+{
+ SCM msg_string = scm_from_locale_string (msg);
+ SCM filename = SCM_BOOL_F;
+ SCM linenr = SCM_BOOL_F;
+ const char *format;
+ SCM args;
+
+ if (scm_is_pair (form))
+ {
+ filename = scm_source_property (form, scm_sym_filename);
+ linenr = scm_source_property (form, scm_sym_line);
+ }
+
+ if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
+ {
+ filename = scm_source_property (expr, scm_sym_filename);
+ linenr = scm_source_property (expr, scm_sym_line);
+ }
+
+ if (!SCM_UNBNDP (expr))
+ {
+ if (scm_is_true (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S in expression ~S.";
+ args = scm_list_5 (filename, linenr, msg_string, form, expr);
+ }
+ else if (scm_is_true (linenr))
+ {
+ format = "In line ~S: ~A ~S in expression ~S.";
+ args = scm_list_4 (linenr, msg_string, form, expr);
+ }
+ else
+ {
+ format = "~A ~S in expression ~S.";
+ args = scm_list_3 (msg_string, form, expr);
+ }
+ }
+ else
+ {
+ if (scm_is_true (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S.";
+ args = scm_list_4 (filename, linenr, msg_string, form);
+ }
+ else if (scm_is_true (linenr))
+ {
+ format = "In line ~S: ~A ~S.";
+ args = scm_list_3 (linenr, msg_string, form);
+ }
+ else
+ {
+ format = "~A ~S.";
+ args = scm_list_2 (msg_string, form);
+ }
+ }
+
+ scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
+}
+
+
+/* Shortcut macros to simplify syntax error handling. */
+#define ASSERT_SYNTAX(cond, message, form) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, SCM_UNDEFINED); }
+#define ASSERT_SYNTAX_2(cond, message, form, expr) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, expr); }
+
+\f
+
+
+/* {Evaluator memoized expressions}
+ */
+
+scm_t_bits scm_tc16_memoized;
+
+#define MAKMEMO(n, args) (scm_cell (scm_tc16_memoized | ((n) << 16), (scm_t_bits)(args)))
+
+#define MAKMEMO_BEGIN(exps) \
+ MAKMEMO (SCM_M_BEGIN, exps)
+#define MAKMEMO_IF(test, then, else_) \
+ MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
+#define MAKMEMO_LAMBDA(nreq, rest, body) \
+ MAKMEMO (SCM_M_LAMBDA, scm_cons (SCM_I_MAKINUM (nreq), scm_cons (rest, body)))
+#define MAKMEMO_LET(inits, body) \
+ MAKMEMO (SCM_M_LET, scm_cons (inits, body))
+#define MAKMEMO_QUOTE(exp) \
+ MAKMEMO (SCM_M_QUOTE, exp)
+#define MAKMEMO_DEFINE(var, val) \
+ MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
+#define MAKMEMO_APPLY(exp) \
+ MAKMEMO (SCM_M_APPLY, exp)
+#define MAKMEMO_CONT(proc) \
+ MAKMEMO (SCM_M_CONT, proc)
+#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
+ MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
+#define MAKMEMO_CALL(proc, args) \
+ MAKMEMO (SCM_M_CALL, scm_cons (proc, args))
+#define MAKMEMO_LEX_REF(n) \
+ MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
+#define MAKMEMO_LEX_SET(n, val) \
+ MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val))
+#define MAKMEMO_TOP_REF(var) \
+ MAKMEMO (SCM_M_TOPLEVEL_REF, var)
+#define MAKMEMO_TOP_SET(var, val) \
+ MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
+#define MAKMEMO_MOD_REF(mod, var, public) \
+ MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
+#define MAKMEMO_MOD_SET(val, mod, var, public) \
+ MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
+
+\f
+
+/* This table must agree with the list of M_ constants in memoize.h */
+static const char *const memoized_tags[] =
+{
+ "begin",
+ "if",
+ "lambda",
+ "let",
+ "quote",
+ "define",
+ "apply",
+ "call/cc",
+ "call-with-values",
+ "call",
+ "lexical-ref",
+ "lexical-set!",
+ "toplevel-ref",
+ "toplevel-set!",
+ "module-ref",
+ "module-set!",
+};
+
+static int
+scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<memoized ", port);
+ scm_write (scm_unmemoize_expression (memoized), port);
+ scm_puts (">", port);
+ return 1;
+}
+
+static SCM scm_m_at (SCM xorig, SCM env);
+static SCM scm_m_atat (SCM xorig, SCM env);
+static SCM scm_m_and (SCM xorig, SCM env);
+static SCM scm_m_apply (SCM xorig, SCM env);
+static SCM scm_m_begin (SCM xorig, SCM env);
+static SCM scm_m_cont (SCM xorig, SCM env);
+static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+static SCM scm_m_cond (SCM xorig, SCM env);
+static SCM scm_m_define (SCM x, SCM env);
+static SCM scm_m_eval_when (SCM xorig, SCM env);
+static SCM scm_m_if (SCM xorig, SCM env);
+static SCM scm_m_lambda (SCM xorig, SCM env);
+static SCM scm_m_let (SCM xorig, SCM env);
+static SCM scm_m_letrec (SCM xorig, SCM env);
+static SCM scm_m_letstar (SCM xorig, SCM env);
+static SCM scm_m_or (SCM xorig, SCM env);
+static SCM scm_m_quote (SCM xorig, SCM env);
+static SCM scm_m_set_x (SCM xorig, SCM env);
+
+
+\f
+
+
+typedef SCM (*t_syntax_transformer) (SCM, SCM);
+
+static t_syntax_transformer
+memoize_env_ref_transformer (SCM env, SCM x)
+{
+ SCM var;
+ for (; scm_is_pair (env); env = CDR (env))
+ if (scm_is_eq (x, CAR (env)))
+ return NULL; /* lexical */
+
+ var = scm_module_variable (env, x);
+ if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
+ && SCM_MACROP (scm_variable_ref (var)))
+ {
+ SCM mac = scm_variable_ref (var);
+ if (SCM_IMP (SCM_MACRO_CODE (mac))
+ || (SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_gsubr))
+ syntax_error ("bad macro", x, SCM_UNDEFINED);
+ else
+ return (t_syntax_transformer)SCM_SUBRF (SCM_MACRO_CODE (mac)); /* global macro */
+ }
+ else
+ return NULL; /* anything else */
+}
+
+static int
+memoize_env_var_is_free (SCM env, SCM x)
+{
+ for (; scm_is_pair (env); env = CDR (env))
+ if (scm_is_eq (x, CAR (env)))
+ return 0; /* bound */
+ return 1; /* free */
+}
+
+static int
+memoize_env_lexical_index (SCM env, SCM x)
+{
+ int i = 0;
+ for (; scm_is_pair (env); env = CDR (env), i++)
+ if (scm_is_eq (x, CAR (env)))
+ return i; /* bound */
+ return -1; /* free */
+}
+
+static SCM
+memoize_env_extend (SCM env, SCM vars)
+{
+ return scm_append (scm_list_2 (vars, env));
+}
+
+static SCM
+memoize (SCM exp, SCM env)
+{
+ if (scm_is_pair (exp))
+ {
+ SCM CAR;
+ t_syntax_transformer trans;
+
+ CAR = CAR (exp);
+ if (scm_is_symbol (CAR))
+ trans = memoize_env_ref_transformer (env, CAR);
+ else
+ trans = NULL;
+
+ if (trans)
+ return trans (exp, env);
+ else
+ {
+ SCM args = SCM_EOL;
+ for (; scm_is_pair (exp); exp = CDR (exp))
+ args = scm_cons (memoize (CAR (exp), env), args);
+ if (scm_is_null (exp))
+ return MAKMEMO (SCM_M_CALL, scm_reverse_x (args, SCM_UNDEFINED));
+ else
+ syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
+ }
+ }
+ else if (scm_is_symbol (exp))
+ {
+ int i = memoize_env_lexical_index (env, exp);
+ if (i < 0)
+ return MAKMEMO_TOP_REF (exp);
+ else
+ return MAKMEMO_LEX_REF (i);
+ }
+ else
+ return MAKMEMO_QUOTE (exp);
+}
+
+static SCM
+memoize_exprs (SCM forms, const SCM env)
+{
+ SCM ret = SCM_EOL;
+
+ for (; !scm_is_null (forms); forms = CDR (forms))
+ ret = scm_cons (memoize (CAR (forms), env), ret);
+ return scm_reverse_x (ret, SCM_UNDEFINED);
+}
+
+static SCM
+memoize_sequence (const SCM forms, const SCM env)
+{
+ ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
+ scm_cons (scm_sym_begin, forms));
+ return MAKMEMO_BEGIN (memoize_exprs (forms, env));
+}
+
+
+\f
+/* Memoization. */
+
+/* bimacros (built-in macros) have isym codes.
+ mmacros don't exist at runtime, they just expand out to more primitive
+ forms. */
+SCM_SYNTAX (s_at, "@", scm_i_makbimacro, scm_m_at);
+SCM_SYNTAX (s_atat, "@@", scm_i_makbimacro, scm_m_atat);
+SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
+SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
+SCM_SYNTAX (s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
+SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
+SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond);
+SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
+SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
+SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
+SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
+SCM_SYNTAX (s_let, "let", scm_i_makbimacro, scm_m_let);
+SCM_SYNTAX (s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
+SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
+SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
+SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
+SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x);
+SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
+
+
+SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
+SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
+SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
+SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
+SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
+SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
+SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
+SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
+SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
+SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
+SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
+SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
+SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
+SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
+SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
+SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
+SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
+SCM_SYMBOL (sym_eval, "eval");
+SCM_SYMBOL (sym_load, "load");
+
+SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
+SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
+
+
+static SCM
+scm_m_at (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
+
+ return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_T);
+}
+
+static SCM
+scm_m_atat (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
+
+ return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_F);
+}
+
+static SCM
+scm_m_and (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+
+ if (scm_is_null (cdr_expr))
+ return MAKMEMO_QUOTE (SCM_BOOL_T);
+ ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
+
+ if (scm_is_null (CDR (cdr_expr)))
+ return memoize (CAR (cdr_expr), env);
+ else
+ return MAKMEMO_IF (memoize (CAR (cdr_expr), env),
+ scm_m_and (cdr_expr, env),
+ MAKMEMO_QUOTE (SCM_BOOL_F));
+}
+
+static SCM
+scm_m_apply (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
+
+ return MAKMEMO_APPLY (memoize_exprs (cdr_expr, env));
+}
+
+static SCM
+scm_m_begin (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
+ return MAKMEMO_BEGIN (memoize_exprs (cdr_expr, env));
+}
+
+static SCM
+scm_m_cont (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+ return MAKMEMO_CONT (memoize (CADR (expr), env));
+}
+
+static SCM
+scm_m_at_call_with_values (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+
+ return MAKMEMO_CALL_WITH_VALUES (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env));
+}
+
+static SCM
+scm_m_cond (SCM expr, SCM env)
+{
+ /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
+ const int else_literal_p = memoize_env_var_is_free (env, scm_sym_else);
+ const int arrow_literal_p = memoize_env_var_is_free (env, scm_sym_arrow);
+
+ const SCM clauses = CDR (expr);
+ SCM clause_idx;
+ SCM ret, loc;
+
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
+
+ ret = scm_cons (SCM_UNDEFINED, MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ loc = ret;
+
+ for (clause_idx = clauses;
+ !scm_is_null (clause_idx);
+ clause_idx = CDR (clause_idx))
+ {
+ SCM test;
+
+ const SCM clause = CAR (clause_idx);
+ const long length = scm_ilength (clause);
+ ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
+
+ test = CAR (clause);
+ if (scm_is_eq (test, scm_sym_else) && else_literal_p)
+ {
+ const int last_clause_p = scm_is_null (CDR (clause_idx));
+ ASSERT_SYNTAX_2 (length >= 2,
+ s_bad_cond_clause, clause, expr);
+ ASSERT_SYNTAX_2 (last_clause_p,
+ s_misplaced_else_clause, clause, expr);
+ SCM_SETCDR (loc,
+ memoize (scm_cons (scm_sym_begin, CDR (clause)), env));
+ }
+ else if (length >= 2
+ && scm_is_eq (CADR (clause), scm_sym_arrow)
+ && arrow_literal_p)
+ {
+ SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
+ SCM i;
+ SCM new_env = scm_cons (tmp, env);
+ ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
+ ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
+ i = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
+ MAKMEMO_CALL (memoize (CADDR (clause),
+ scm_cons (tmp, new_env)),
+ scm_list_1 (MAKMEMO_LEX_REF (0))),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc,
+ MAKMEMO_LET (scm_list_1 (memoize (CAR (clause), env)),
+ i));
+ env = new_env;
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
+ }
+ /* FIXME length == 1 case */
+ else
+ {
+ SCM i = MAKMEMO_IF (memoize (CAR (clause), env),
+ memoize (scm_cons (scm_sym_begin, CDR (clause)), env),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc, i);
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
+ }
+ }
+
+ return CDR (ret);
+}
+
+/* According to Section 5.2.1 of R5RS we first have to make sure that the
+ variable is bound, and then perform the `(set! variable expression)'
+ operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
+ bound. This means that EXPRESSION won't necessarily be able to assign
+ values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
+static SCM
+scm_m_define (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ SCM body;
+ SCM variable;
+
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
+
+ body = CDR (cdr_expr);
+ variable = CAR (cdr_expr);
+
+ if (scm_is_pair (variable))
+ {
+ ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
+ return MAKMEMO_DEFINE (CAR (variable),
+ memoize (scm_cons (scm_sym_lambda,
+ scm_cons (CDR (variable), body)),
+ env));
+ }
+ ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
+ ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
+ return MAKMEMO_DEFINE (variable, memoize (CAR (body), env));
+}
+
+static SCM
+scm_m_eval_when (SCM expr, SCM env)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+
+ if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
+ || scm_is_true (scm_memq (sym_load, CADR (expr))))
+ return MAKMEMO_BEGIN (memoize_exprs (CDDR (expr), env));
+ else
+ return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
+}
+
+static SCM
+scm_m_if (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
+ return MAKMEMO_IF (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env),
+ ((length == 3)
+ ? memoize (CADDDR (expr), env)
+ : MAKMEMO_QUOTE (SCM_UNSPECIFIED)));
+}
+
+/* A helper function for memoize_lambda to support checking for duplicate
+ * formal arguments: Return true if OBJ is `eq?' to one of the elements of
+ * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
+ * forms that a formal argument can have:
+ * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
+static int
+c_improper_memq (SCM obj, SCM list)
+{
+ for (; scm_is_pair (list); list = CDR (list))
+ {
+ if (scm_is_eq (CAR (list), obj))
+ return 1;
+ }
+ return scm_is_eq (list, obj);
+}
+
+static SCM
+scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM formals;
+ SCM formals_idx;
+ SCM formal_vars = SCM_EOL;
+ int nreq = 0;
+
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ /* Before iterating the list of formal arguments, make sure the formals
+ * actually are given as either a symbol or a non-cyclic list. */
+ formals = CAR (cdr_expr);
+ if (scm_is_pair (formals))
+ {
+ /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
+ * detected, report a 'Bad formals' error. */
+ }
+ else
+ {
+ ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
+ s_bad_formals, formals, expr);
+ }
+
+ /* Now iterate the list of formal arguments to check if all formals are
+ * symbols, and that there are no duplicates. */
+ formals_idx = formals;
+ while (scm_is_pair (formals_idx))
+ {
+ const SCM formal = CAR (formals_idx);
+ const SCM next_idx = CDR (formals_idx);
+ ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
+ ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
+ s_duplicate_formal, formal, expr);
+ nreq++;
+ formal_vars = scm_cons (formal, formal_vars);
+ formals_idx = next_idx;
+ }
+ ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
+ s_bad_formal, formals_idx, expr);
+ if (scm_is_symbol (formals_idx))
+ formal_vars = scm_cons (formals_idx, formal_vars);
+ return MAKMEMO_LAMBDA (nreq, scm_symbol_p (formals_idx),
+ memoize_sequence (CDDR (expr),
+ memoize_env_extend (env, formal_vars)));
+}
+
+/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
+static void
+check_bindings (const SCM bindings, const SCM expr)
+{
+ SCM binding_idx;
+
+ ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
+ s_bad_bindings, bindings, expr);
+
+ binding_idx = bindings;
+ for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ {
+ SCM name; /* const */
+
+ const SCM binding = CAR (binding_idx);
+ ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
+ s_bad_binding, binding, expr);
+
+ name = CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
+ }
+}
+
+/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
+ * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
+ * variable name is detected, an error is signalled. */
+static int
+transform_bindings (const SCM bindings, const SCM expr,
+ SCM *const rvarptr, SCM *const initptr)
+{
+ SCM rvariables = SCM_EOL;
+ SCM rinits = SCM_EOL;
+ SCM binding_idx = bindings;
+ int n = 0;
+ for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ {
+ const SCM binding = CAR (binding_idx);
+ const SCM CDR_binding = CDR (binding);
+ const SCM name = CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
+ s_duplicate_binding, name, expr);
+ rvariables = scm_cons (name, rvariables);
+ rinits = scm_cons (CAR (CDR_binding), rinits);
+ n++;
+ }
+ *rvarptr = rvariables;
+ *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
+ return n;
+}
+
+/* This function is a helper function for memoize_let. It transforms
+ * (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
+ * and memoizes the expression. It is assumed that the caller has checked
+ * that name is a symbol and that there are bindings and a body. */
+static SCM
+memoize_named_let (const SCM expr, SCM env)
+{
+ SCM rvariables;
+ SCM inits;
+ int nreq;
+
+ const SCM cdr_expr = CDR (expr);
+ const SCM name = CAR (cdr_expr);
+ const SCM cddr_expr = CDR (cdr_expr);
+ const SCM bindings = CAR (cddr_expr);
+ check_bindings (bindings, expr);
+
+ nreq = transform_bindings (bindings, expr, &rvariables, &inits);
+
+ env = scm_cons (name, env);
+ return MAKMEMO_LET
+ (scm_list_1 (MAKMEMO_QUOTE (SCM_UNDEFINED)),
+ MAKMEMO_BEGIN
+ (scm_list_2 (MAKMEMO_LEX_SET
+ (0,
+ MAKMEMO_LAMBDA
+ (nreq, SCM_BOOL_F,
+ memoize_sequence (CDDDR (expr),
+ memoize_env_extend (env, rvariables)))),
+ MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
+ memoize_exprs (inits, env)))));
+}
+
+/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
+ * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
+static SCM
+scm_m_let (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ bindings = CAR (cdr_expr);
+ if (scm_is_symbol (bindings))
+ {
+ ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
+ return memoize_named_let (expr, env);
+ }
+
+ check_bindings (bindings, expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ return MAKMEMO_LET (memoize_exprs (inits, env),
+ memoize_sequence (CDDR (expr),
+ memoize_env_extend (env, rvariables)));
+ }
+}
+
+static SCM
+scm_m_letrec (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ bindings = CAR (cdr_expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ SCM v, i;
+ SCM undefs = SCM_EOL;
+ SCM vals = SCM_EOL;
+ SCM sets = SCM_EOL;
+ SCM new_env;
+ int offset;
+ int n = transform_bindings (bindings, expr, &rvariables, &inits);
+ offset = n;
+ new_env = memoize_env_extend (env, rvariables);
+ for (v = scm_reverse (rvariables), i = inits; scm_is_pair (v);
+ v = CDR (v), i = CDR (i), n--)
+ {
+ undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
+ vals = scm_cons (memoize (CAR (i), new_env), vals);
+ sets = scm_cons (MAKMEMO_LEX_SET ((n-1) + offset,
+ MAKMEMO_LEX_REF (n-1)),
+ sets);
+ }
+ return MAKMEMO_LET
+ (undefs,
+ MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (scm_reverse (vals),
+ MAKMEMO_BEGIN (sets)),
+ memoize_sequence (CDDR (expr),
+ new_env))));
+ }
+}
+
+static SCM
+scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ bindings = CAR (cdr_expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM variables;
+ SCM inits;
+ SCM ret, loc;
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ variables = scm_reverse (rvariables);
+ ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
+ loc = ret;
+ for (; scm_is_pair (variables);
+ variables = CDR (variables), inits = CDR (inits))
+ { SCM x = MAKMEMO_LET (scm_list_1 (memoize (CAR (inits), env)),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc, x);
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
+ env = scm_cons (CAR (variables), env);
+ }
+ SCM_SETCDR (loc, memoize_sequence (CDDR (expr), env));
+ return CDR (ret);
+ }
+}
+
+static SCM
+scm_m_or (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM tail = CDR (expr);
+ SCM ret, loc;
+ const long length = scm_ilength (tail);
+
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+
+ ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
+ loc = ret;
+ for (; scm_is_pair (tail); tail = CDR (tail))
+ {
+ SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
+ SCM x = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
+ MAKMEMO_LEX_REF (0),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM new_env = scm_cons (tmp, env);
+ SCM_SETCDR (loc, MAKMEMO_LET (scm_list_1 (memoize (CAR (tail),
+ env)),
+ x));
+ env = new_env;
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
+ }
+ SCM_SETCDR (loc, MAKMEMO_QUOTE (SCM_BOOL_F));
+ return CDR (ret);
+}
+
+static SCM
+scm_m_quote (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM quotee;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+ quotee = CAR (cdr_expr);
+ return MAKMEMO_QUOTE (quotee);
+}
+
+static SCM
+scm_m_set_x (SCM expr, SCM env)
+{
+ SCM variable;
+ SCM vmem;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ variable = CAR (cdr_expr);
+ vmem = memoize (variable, env);
+
+ switch (SCM_MEMOIZED_TAG (vmem))
+ {
+ case SCM_M_LEXICAL_REF:
+ return MAKMEMO_LEX_SET (SCM_I_INUM (SCM_MEMOIZED_ARGS (vmem)),
+ memoize (CADDR (expr), env));
+ case SCM_M_TOPLEVEL_REF:
+ return MAKMEMO_TOP_SET (variable,
+ memoize (CADDR (expr), env));
+ case SCM_M_MODULE_REF:
+ return MAKMEMO_MOD_SET (memoize (CADDR (expr), env),
+ CAR (SCM_MEMOIZED_ARGS (vmem)),
+ CADR (SCM_MEMOIZED_ARGS (vmem)),
+ CDDR (SCM_MEMOIZED_ARGS (vmem)));
+ default:
+ syntax_error (s_bad_variable, variable, expr);
+ }
+}
+
+
+\f
+
+SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
+ (SCM exp),
+ "Memoize the expression @var{exp}.")
+#define FUNC_NAME s_scm_memoize_expression
+{
+ return memoize (exp, scm_current_module ());
+}
+#undef FUNC_NAME
+
+\f
+
+
+SCM_SYMBOL (sym_placeholder, "_");
+
+static SCM unmemoize (SCM expr);
+
+static SCM
+unmemoize_exprs (SCM exprs)
+{
+ SCM ret, tail;
+ if (scm_is_null (exprs))
+ return SCM_EOL;
+ ret = scm_list_1 (unmemoize (CAR (exprs)));
+ tail = ret;
+ for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
+ {
+ SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
+ tail = CDR (tail);
+ }
+ return ret;
+}
+
+static SCM
+unmemoize_bindings (SCM inits)
+{
+ SCM ret, tail;
+ if (scm_is_null (inits))
+ return SCM_EOL;
+ ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits))));
+ tail = ret;
+ for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits))
+ {
+ SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder,
+ unmemoize (CAR (inits)))));
+ tail = CDR (tail);
+ }
+ return ret;
+}
+
+static SCM
+unmemoize_lexical (SCM n)
+{
+ char buf[16];
+ buf[15] = 0;
+ snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
+ return scm_from_locale_symbol (buf);
+}
+
+static SCM
+unmemoize (const SCM expr)
+{
+ SCM args;
+
+ if (!SCM_MEMOIZED_P (expr))
+ abort ();
+
+ args = SCM_MEMOIZED_ARGS (expr);
+ switch (SCM_MEMOIZED_TAG (expr))
+ {
+ case SCM_M_APPLY:
+ return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
+ case SCM_M_BEGIN:
+ return scm_cons (scm_sym_begin, unmemoize_exprs (args));
+ case SCM_M_CALL:
+ return unmemoize_exprs (args);
+ case SCM_M_CONT:
+ return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
+ case SCM_M_CALL_WITH_VALUES:
+ return scm_list_3 (scm_sym_at_call_with_values,
+ unmemoize (CAR (args)), unmemoize (CDR (args)));
+ case SCM_M_DEFINE:
+ return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_IF:
+ return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
+ unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
+ case SCM_M_LAMBDA:
+ return scm_list_3 (scm_sym_lambda,
+ scm_make_list (CAR (args), sym_placeholder),
+ unmemoize (CDDR (args)));
+ case SCM_M_LET:
+ return scm_list_3 (scm_sym_let,
+ unmemoize_bindings (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_QUOTE:
+ return scm_list_2 (scm_sym_quote, args);
+ case SCM_M_LEXICAL_REF:
+ return unmemoize_lexical (args);
+ case SCM_M_LEXICAL_SET:
+ return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_TOPLEVEL_REF:
+ return args;
+ case SCM_M_TOPLEVEL_SET:
+ return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_MODULE_REF:
+ return scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CAR (args)),
+ CADR (args));
+ case SCM_M_MODULE_SET:
+ return scm_list_3 (scm_sym_set_x,
+ scm_list_3 (scm_is_true (CDDDR (args))
+ ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CADR (args)),
+ CADDR (args)),
+ unmemoize (CAR (args)));
+ default:
+ abort ();
+ }
+}
+
+SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is memoized.")
+#define FUNC_NAME s_scm_memoized_p
+{
+ return scm_from_bool (SCM_MEMOIZED_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
+ (SCM m),
+ "Unmemoize the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_unmemoize_expression
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return unmemoize (m);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode", 1, 0, 0,
+ (SCM m),
+ "Return the typecode from the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_memoized_expression_typecode
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return scm_from_uint16 (SCM_MEMOIZED_TAG (m));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0,
+ (SCM m),
+ "Return the data from the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_memoized_expression_data
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return SCM_MEMOIZED_ARGS (m);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
+ (SCM sym),
+ "Return the memoized typecode corresponding to the symbol @var{sym}.")
+#define FUNC_NAME s_scm_memoized_typecode
+{
+ int i;
+
+ SCM_VALIDATE_SYMBOL (1, sym);
+
+ for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
+ if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
+ return scm_from_int32 (i);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void error_unbound_variable (SCM symbol)
+{
+ scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
+ scm_list_1 (symbol), SCM_BOOL_F);
+}
+
+SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0,
+ (SCM m, SCM mod),
+ "Look up and cache the variable that @var{m} will access, returning the variable.")
+#define FUNC_NAME s_scm_memoize_variable_access_x
+{
+ SCM mx;
+ SCM_VALIDATE_MEMOIZED (1, m);
+ mx = SCM_MEMOIZED_ARGS (m);
+ switch (SCM_MEMOIZED_TAG (m))
+ {
+ case SCM_M_TOPLEVEL_REF:
+ if (SCM_VARIABLEP (mx))
+ return mx;
+ else
+ {
+ SCM var = scm_module_variable (mod, mx);
+ if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
+ error_unbound_variable (mx);
+ SCM_SET_SMOB_OBJECT (m, var);
+ return var;
+ }
+
+ case SCM_M_TOPLEVEL_SET:
+ {
+ SCM var = CAR (mx);
+ if (SCM_VARIABLEP (var))
+ return var;
+ else
+ {
+ var = scm_module_variable (mod, var);
+ if (scm_is_false (var))
+ error_unbound_variable (CAR (mx));
+ SCM_SETCAR (mx, var);
+ return var;
+ }
+ }
+
+ case SCM_M_MODULE_REF:
+ if (SCM_VARIABLEP (mx))
+ return mx;
+ else
+ {
+ SCM var;
+ mod = scm_resolve_module (CAR (mx));
+ if (scm_is_true (CDDR (mx)))
+ mod = scm_module_public_interface (mod);
+ var = scm_module_lookup (mod, CADR (mx));
+ if (scm_is_false (scm_variable_bound_p (var)))
+ error_unbound_variable (CADR (mx));
+ SCM_SET_SMOB_OBJECT (m, var);
+ return var;
+ }
+
+ case SCM_M_MODULE_SET:
+ /* FIXME: not quite threadsafe */
+ if (SCM_VARIABLEP (CDR (mx)))
+ return CDR (mx);
+ else
+ {
+ SCM var;
+ mod = scm_resolve_module (CADR (mx));
+ if (scm_is_true (CDDDR (mx)))
+ mod = scm_module_public_interface (mod);
+ var = scm_module_lookup (mod, CADDR (mx));
+ SCM_SETCDR (mx, var);
+ return var;
+ }
+
+ default:
+ scm_wrong_type_arg (FUNC_NAME, 1, m);
+ return SCM_BOOL_F;
+ }
+}
+#undef FUNC_NAME
+
+
+\f
+
+void
+scm_init_memoize ()
+{
+ scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
+ scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
+ scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
+
+#include "libguile/memoize.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_MEMOIZE_H
+#define SCM_MEMOIZE_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
+ * 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+
+\f
+
+SCM_API SCM scm_sym_and;
+SCM_API SCM scm_sym_begin;
+SCM_API SCM scm_sym_case;
+SCM_API SCM scm_sym_cond;
+SCM_API SCM scm_sym_define;
+SCM_API SCM scm_sym_do;
+SCM_API SCM scm_sym_if;
+SCM_API SCM scm_sym_lambda;
+SCM_API SCM scm_sym_let;
+SCM_API SCM scm_sym_letstar;
+SCM_API SCM scm_sym_letrec;
+SCM_API SCM scm_sym_quote;
+SCM_API SCM scm_sym_quasiquote;
+SCM_API SCM scm_sym_unquote;
+SCM_API SCM scm_sym_uq_splicing;
+
+SCM_API SCM scm_sym_at;
+SCM_API SCM scm_sym_atat;
+SCM_API SCM scm_sym_atapply;
+SCM_API SCM scm_sym_atcall_cc;
+SCM_API SCM scm_sym_at_call_with_values;
+SCM_API SCM scm_sym_delay;
+SCM_API SCM scm_sym_eval_when;
+SCM_API SCM scm_sym_arrow;
+SCM_API SCM scm_sym_else;
+SCM_API SCM scm_sym_apply;
+SCM_API SCM scm_sym_set_x;
+SCM_API SCM scm_sym_args;
+
+/* {Memoized Source}
+ */
+
+SCM_INTERNAL scm_t_bits scm_tc16_memoized;
+
+#define SCM_MEMOIZED_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoized, (x)))
+#define SCM_MEMOIZED_TAG(x) (SCM_SMOB_FLAGS (x))
+#define SCM_MEMOIZED_ARGS(x) (SCM_SMOB_OBJECT (x))
+
+enum
+ {
+ SCM_M_BEGIN,
+ SCM_M_IF,
+ SCM_M_LAMBDA,
+ SCM_M_LET,
+ SCM_M_QUOTE,
+ SCM_M_DEFINE,
+ SCM_M_APPLY,
+ SCM_M_CONT,
+ SCM_M_CALL_WITH_VALUES,
+ SCM_M_CALL,
+ SCM_M_LEXICAL_REF,
+ SCM_M_LEXICAL_SET,
+ SCM_M_TOPLEVEL_REF,
+ SCM_M_TOPLEVEL_SET,
+ SCM_M_MODULE_REF,
+ SCM_M_MODULE_SET
+ };
+
+
+\f
+
+SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
+SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_expression_typecode (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_expression_data (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_typecode (SCM sym);
+SCM_INTERNAL SCM scm_memoize_variable_access_x (SCM memoized, SCM module);
+SCM_API SCM scm_memoized_p (SCM obj);
+
+SCM_INTERNAL void scm_init_memoize (void);
+
+
+#endif /* SCM_MEMOIZE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009 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
static SCM the_root_module_var;
-static SCM
-the_root_module ()
+static SCM unbound_variable (const char *func, SCM sym)
+{
+ scm_error (scm_from_locale_symbol ("unbound-variable"), func,
+ "Unbound variable: ~S", scm_list_1 (sym), SCM_BOOL_F);
+}
+
+SCM
+scm_the_root_module (void)
{
if (scm_module_system_booted_p)
return SCM_VARIABLE_REF (the_root_module_var);
{
SCM curr = scm_fluid_ref (the_module);
- return scm_is_true (curr) ? curr : the_root_module ();
+ return scm_is_true (curr) ? curr : scm_the_root_module ();
}
#undef FUNC_NAME
/* Environments */
-SCM
-scm_top_level_env (SCM thunk)
-{
- if (SCM_IMP (thunk))
- return SCM_EOL;
- else
- return scm_cons (thunk, SCM_EOL);
-}
-
-SCM
-scm_env_top_level (SCM env)
-{
- while (scm_is_pair (env))
- {
- SCM car_env = SCM_CAR (env);
- if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
- return car_env;
- env = SCM_CDR (env);
- }
- return SCM_BOOL_F;
-}
-
SCM_SYMBOL (sym_module, "module");
SCM
scm_lookup_closure_module (SCM proc)
{
if (scm_is_false (proc))
- return the_root_module ();
+ return scm_the_root_module ();
else if (SCM_EVAL_CLOSURE_P (proc))
return SCM_PACK (SCM_SMOB_DATA (proc));
else
{
- SCM mod = scm_procedure_property (proc, sym_module);
+ SCM mod;
+
+ /* FIXME: The `module' property is no longer set. See
+ `set-module-eval-closure!' in `boot-9.scm'. */
+ abort ();
+
+ mod = scm_procedure_property (proc, sym_module);
if (scm_is_false (mod))
- mod = the_root_module ();
+ mod = scm_the_root_module ();
return mod;
}
}
-SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
- (SCM env),
- "Return the module of @var{ENV}, a lexical environment.")
-#define FUNC_NAME s_scm_env_module
-{
- return scm_lookup_closure_module (scm_env_top_level (env));
-}
-#undef FUNC_NAME
-
/*
* C level implementation of the standard eval closure
*
scm_t_bits scm_tc16_eval_closure;
-#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
+#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
- (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
+ (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
/* NOTE: This function may be called by a smob application
or from another C function directly. */
"Such a closure does not allow new bindings to be added.")
#define FUNC_NAME s_scm_standard_interface_eval_closure
{
- SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | (SCM_F_EVAL_CLOSURE_INTERFACE<<16),
SCM_UNPACK (module));
}
#undef FUNC_NAME
SCM_SYMBOL (sym_sys_pre_modules_transformer, "%pre-modules-transformer");
-SCM
-scm_module_transformer (SCM module)
+SCM_DEFINE (scm_module_transformer, "module-transformer", 1, 0, 0,
+ (SCM module),
+ "Returns the syntax expander for the given module.")
+#define FUNC_NAME s_scm_module_transformer
{
if (SCM_UNLIKELY (scm_is_false (module)))
{ SCM v = scm_hashq_ref (scm_pre_modules_obarray,
return SCM_VARIABLE_REF (v);
}
else
- return SCM_MODULE_TRANSFORMER (module);
+ {
+ SCM_VALIDATE_MODULE (SCM_ARG1, module);
+ return SCM_MODULE_TRANSFORMER (module);
+ }
}
+#undef FUNC_NAME
SCM
scm_current_module_transformer ()
var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
if (scm_is_false (var))
- SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
+ unbound_variable (FUNC_NAME, sym);
return var;
}
#undef FUNC_NAME
SCM var =
scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
if (scm_is_false (var))
- scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
+ unbound_variable (NULL, sym);
return var;
}
return scm_define (scm_from_locale_symbol (name), value);
}
-SCM
-scm_define (SCM sym, SCM value)
+SCM_DEFINE (scm_define, "define!", 2, 0, 0,
+ (SCM sym, SCM value),
+ "Define @var{sym} to be @var{value} in the current module."
+ "Returns the variable itself. Note that this is a procedure, "
+ "not a macro.")
+#define FUNC_NAME s_scm_define
{
- SCM var =
- scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
+ SCM var;
+ SCM_VALIDATE_SYMBOL (SCM_ARG1, sym);
+ var = scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
SCM_VARIABLE_SET (var, value);
return var;
}
+#undef FUNC_NAME
SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
(SCM module, SCM variable),
while (!scm_is_null (ls))
{
handle = SCM_CAR (ls);
- if (SCM_CDR (handle) == variable)
- return SCM_CAR (handle);
+
+ if (SCM_CAR (handle) == SCM_PACK (NULL))
+ {
+ /* FIXME: We hit a weak pair whose car has become unreachable.
+ We should remove the pair in question or something. */
+ }
+ else
+ {
+ if (SCM_CDR (handle) == variable)
+ return SCM_CAR (handle);
+ }
+
ls = SCM_CDR (ls);
}
}
SCM_SYMBOL (scm_sym_system_module, "system-module");
-SCM
-scm_system_module_env_p (SCM env)
-{
- SCM proc = scm_env_top_level (env);
- if (scm_is_false (proc))
- return SCM_BOOL_T;
- return ((scm_is_true (scm_procedure_property (proc,
- scm_sym_system_module)))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
void
scm_modules_prehistory ()
{
- scm_pre_modules_obarray
- = scm_permanent_object (scm_c_make_hash_table (1533));
+ scm_pre_modules_obarray = scm_c_make_hash_table (1533);
}
void
module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
SCM_UNDEFINED);
scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
- scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
- the_module = scm_permanent_object (scm_make_fluid ());
+ the_module = scm_make_fluid ();
}
static void
scm_post_boot_init_modules ()
{
-#define PERM(x) scm_permanent_object(x)
-
SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
- resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
- process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
- process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
- module_export_x_var = PERM (scm_c_lookup ("module-export!"));
- the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
- default_duplicate_binding_procedures_var =
- PERM (scm_c_lookup ("default-duplicate-binding-procedures"));
+ resolve_module_var = scm_c_lookup ("resolve-module");
+ process_define_module_var = scm_c_lookup ("process-define-module");
+ process_use_modules_var = scm_c_lookup ("process-use-modules");
+ module_export_x_var = scm_c_lookup ("module-export!");
+ the_root_module_var = scm_c_lookup ("the-root-module");
+ default_duplicate_binding_procedures_var =
+ scm_c_lookup ("default-duplicate-binding-procedures");
scm_module_system_booted_p = 1;
}
\f
SCM_API SCM scm_current_module (void);
+SCM_API SCM scm_the_root_module (void);
SCM_API SCM scm_module_variable (SCM module, SCM sym);
SCM_API SCM scm_module_local_variable (SCM module, SCM sym);
SCM_API SCM scm_interaction_environment (void);
SCM_API SCM scm_get_pre_modules_obarray (void);
SCM_API SCM scm_lookup_closure_module (SCM proc);
-SCM_API SCM scm_env_top_level (SCM env);
-SCM_API SCM scm_env_module (SCM env);
-SCM_API SCM scm_top_level_env (SCM thunk);
-SCM_API SCM scm_system_module_env_p (SCM env);
-
SCM_INTERNAL void scm_modules_prehistory (void);
SCM_INTERNAL void scm_init_modules (void);
/* the macro above will not work as is with fractions */
+static SCM flo0;
+
#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
/* FLOBUFLEN is the maximum number of characters neccessary for the
#endif
+#if !defined (HAVE_ASINH)
+static double asinh (double x) { return log (x + sqrt (x * x + 1)); }
+#endif
+#if !defined (HAVE_ACOSH)
+static double acosh (double x) { return log (x + sqrt (x * x - 1)); }
+#endif
+#if !defined (HAVE_ATANH)
+static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); }
+#endif
+
/* mpz_cmp_d in gmp 4.1.3 doesn't recognise infinities, so xmpz_cmp_d uses
an explicit check. In some future gmp (don't know what version number),
mpz_cmp_d is supposed to do this itself. */
before trying to use it. (But in practice we believe this is not a
problem on any system guile is likely to target.) */
guile_Inf = INFINITY;
-#elif HAVE_DINFINITY
+#elif defined HAVE_DINFINITY
/* OSF */
extern unsigned int DINFINITY[2];
guile_Inf = (*((double *) (DINFINITY)));
#ifdef NAN
/* C99 NAN, when available */
guile_NaN = NAN;
-#elif HAVE_DQNAN
+#elif defined HAVE_DQNAN
{
/* OSF */
extern unsigned int DQNAN[2];
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);
}
-SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
-/* "Return the greatest common divisor of all arguments.\n"
- * "If called without arguments, 0 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the greatest common divisor of all parameter values.\n"
+ "If called without arguments, 0 is returned.")
+#define FUNC_NAME s_scm_i_gcd
+{
+ while (!scm_is_null (rest))
+ { x = scm_gcd (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_gcd (x, y);
+}
+#undef FUNC_NAME
+
+#define s_gcd s_scm_i_gcd
+#define g_gcd g_scm_i_gcd
+
SCM
scm_gcd (SCM x, SCM y)
{
SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
}
-SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
-/* "Return the least common multiple of the arguments.\n"
- * "If called without arguments, 1 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the least common multiple of the arguments.\n"
+ "If called without arguments, 1 is returned.")
+#define FUNC_NAME s_scm_i_lcm
+{
+ while (!scm_is_null (rest))
+ { x = scm_lcm (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_lcm (x, y);
+}
+#undef FUNC_NAME
+
+#define s_lcm s_scm_i_lcm
+#define g_lcm g_scm_i_lcm
+
SCM
scm_lcm (SCM n1, SCM n2)
{
*/
-SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
- (SCM n1, SCM n2),
- "Return the bitwise AND of the integer arguments.\n\n"
- "@lisp\n"
- "(logand) @result{} -1\n"
- "(logand 7) @result{} 7\n"
- "(logand #b111 #b011 #b001) @result{} 1\n"
- "@end lisp")
+SCM_DEFINE (scm_i_logand, "logand", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the bitwise AND of the integer arguments.\n\n"
+ "@lisp\n"
+ "(logand) @result{} -1\n"
+ "(logand 7) @result{} 7\n"
+ "(logand #b111 #b011 #b001) @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_logand
+{
+ while (!scm_is_null (rest))
+ { x = scm_logand (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logand (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logand s_scm_i_logand
+
+SCM scm_logand (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logand
{
long int nn1;
#undef FUNC_NAME
-SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
- (SCM n1, SCM n2),
- "Return the bitwise OR of the integer arguments.\n\n"
- "@lisp\n"
- "(logior) @result{} 0\n"
- "(logior 7) @result{} 7\n"
- "(logior #b000 #b001 #b011) @result{} 3\n"
- "@end lisp")
+SCM_DEFINE (scm_i_logior, "logior", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the bitwise OR of the integer arguments.\n\n"
+ "@lisp\n"
+ "(logior) @result{} 0\n"
+ "(logior 7) @result{} 7\n"
+ "(logior #b000 #b001 #b011) @result{} 3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_logior
+{
+ while (!scm_is_null (rest))
+ { x = scm_logior (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logior (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logior s_scm_i_logior
+
+SCM scm_logior (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logior
{
long int nn1;
#undef FUNC_NAME
-SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
- (SCM n1, SCM n2),
+SCM_DEFINE (scm_i_logxor, "logxor", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
"Return the bitwise XOR of the integer arguments. A bit is\n"
"set in the result if it is set in an odd number of arguments.\n"
"@lisp\n"
"(logxor #b000 #b001 #b011) @result{} 2\n"
"(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
"@end lisp")
+#define FUNC_NAME s_scm_i_logxor
+{
+ while (!scm_is_null (rest))
+ { x = scm_logxor (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logxor (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logxor s_scm_i_logxor
+
+SCM scm_logxor (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logxor
{
long int nn1;
#undef FUNC_NAME
-SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
-/* "Return @code{#t} if all parameters are numerically equal." */
+SCM scm_i_num_eq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if all parameters are numerically equal.")
+#define FUNC_NAME s_scm_i_num_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_num_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_num_eq_p (x, y);
+}
+#undef FUNC_NAME
SCM
scm_num_eq_p (SCM x, SCM y)
{
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_REALP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_COMPLEXP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_fraction_equalp (x, y);
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1, s_scm_i_num_eq_p);
}
mpq_cmp. flonum/frac compares likewise, but with the slight complication
of the float exponent to take into account. */
-SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "increasing."
- */
+SCM scm_i_num_less_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is monotonically\n"
+ "increasing.")
+#define FUNC_NAME s_scm_i_num_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_less_p (x, y);
+}
+#undef FUNC_NAME
SCM
scm_less_p (SCM x, SCM y)
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
goto int_frac;
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
}
else if (SCM_REALP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
}
else if (SCM_FRACTIONP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARG1, s_scm_i_num_less_p);
}
-SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "decreasing."
- */
-#define FUNC_NAME s_scm_gr_p
+SCM scm_i_num_gr_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is monotonically\n"
+ "decreasing.")
+#define FUNC_NAME s_scm_i_num_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_gr_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_gr_p
SCM
scm_gr_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
else
return scm_less_p (y, x);
}
#undef FUNC_NAME
-SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "non-decreasing."
- */
-#define FUNC_NAME s_scm_leq_p
+SCM scm_i_num_leq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is monotonically\n"
+ "non-decreasing.")
+#define FUNC_NAME s_scm_i_num_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_leq_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_leq_p
SCM
scm_leq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
#undef FUNC_NAME
-SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "non-increasing."
- */
-#define FUNC_NAME s_scm_geq_p
+SCM scm_i_num_geq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p, ">=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is monotonically\n"
+ "non-increasing.")
+#define FUNC_NAME s_scm_i_num_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_geq_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_geq_p
SCM
scm_geq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
unlike scm_less_p above which takes some trouble to preserve all bits in
its test, such trouble is not required for min and max. */
-SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
-/* "Return the maximum of all parameter values."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_max, "max", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the maximum of all parameter values.")
+#define FUNC_NAME s_scm_i_max
+{
+ while (!scm_is_null (rest))
+ { x = scm_max (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_max (x, y);
+}
+#undef FUNC_NAME
+
+#define s_max s_scm_i_max
+#define g_max g_scm_i_max
+
SCM
scm_max (SCM x, SCM y)
{
}
-SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
-/* "Return the minium of all parameter values."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the minimum of all parameter values.")
+#define FUNC_NAME s_scm_i_min
+{
+ while (!scm_is_null (rest))
+ { x = scm_min (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_min (x, y);
+}
+#undef FUNC_NAME
+
+#define s_min s_scm_i_min
+#define g_min g_scm_i_min
+
SCM
scm_min (SCM x, SCM y)
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
else
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
}
-SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
-/* "Return the sum of all parameter values. Return 0 if called without\n"
- * "any parameters."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_sum, "+", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the sum of all parameter values. Return 0 if called without\n"
+ "any parameters." )
+#define FUNC_NAME s_scm_i_sum
+{
+ while (!scm_is_null (rest))
+ { x = scm_sum (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_sum (x, y);
+}
+#undef FUNC_NAME
+
+#define s_sum s_scm_i_sum
+#define g_sum g_scm_i_sum
+
SCM
scm_sum (SCM x, SCM y)
{
#undef FUNC_NAME
-SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
-/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
- * the sum of all but the first argument are subtracted from the first
- * argument. */
-#define FUNC_NAME s_difference
+SCM_PRIMITIVE_GENERIC (scm_i_difference, "-", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
+ "the sum of all but the first argument are subtracted from the first\n"
+ "argument.")
+#define FUNC_NAME s_scm_i_difference
+{
+ while (!scm_is_null (rest))
+ { x = scm_difference (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_difference (x, y);
+}
+#undef FUNC_NAME
+
+#define s_difference s_scm_i_difference
+#define g_difference g_scm_i_difference
+
SCM
scm_difference (SCM x, SCM y)
+#define FUNC_NAME s_difference
{
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
#undef FUNC_NAME
-SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
-/* "Return the product of all arguments. If called without arguments,\n"
- * "1 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the product of all arguments. If called without arguments,\n"
+ "1 is returned.")
+#define FUNC_NAME s_scm_i_product
+{
+ while (!scm_is_null (rest))
+ { x = scm_product (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_product (x, y);
+}
+#undef FUNC_NAME
+
+#define s_product s_scm_i_product
+#define g_product g_scm_i_product
+
SCM
scm_product (SCM x, SCM y)
{
this software.
****************************************************************/
-SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
-/* Divide the first argument by the product of the remaining
- arguments. If called with one argument @var{z1}, 1/@var{z1} is
- returned. */
-#define FUNC_NAME s_divide
+SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Divide the first argument by the product of the remaining\n"
+ "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
+ "returned.")
+#define FUNC_NAME s_scm_i_divide
+{
+ while (!scm_is_null (rest))
+ { x = scm_divide (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_divide (x, y);
+}
+#undef FUNC_NAME
+
+#define s_divide s_scm_i_divide
+#define g_divide g_scm_i_divide
+
static SCM
-scm_i_divide (SCM x, SCM y, int inexact)
+do_divide (SCM x, SCM y, int inexact)
+#define FUNC_NAME s_divide
{
double a;
SCM
scm_divide (SCM x, SCM y)
{
- return scm_i_divide (x, y, 0);
+ return do_divide (x, y, 0);
}
static SCM scm_divide2real (SCM x, SCM y)
{
- return scm_i_divide (x, y, 1);
+ return do_divide (x, y, 1);
}
#undef FUNC_NAME
-double
-scm_asinh (double x)
-{
-#if HAVE_ASINH
- return asinh (x);
-#else
-#define asinh scm_asinh
- return log (x + sqrt (x * x + 1));
-#endif
-}
-SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh);
-/* "Return the inverse hyperbolic sine of @var{x}."
- */
-
-
-double
-scm_acosh (double x)
-{
-#if HAVE_ACOSH
- return acosh (x);
-#else
-#define acosh scm_acosh
- return log (x + sqrt (x * x - 1));
-#endif
-}
-SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh);
-/* "Return the inverse hyperbolic cosine of @var{x}."
- */
-
-
-double
-scm_atanh (double x)
-{
-#if HAVE_ATANH
- return atanh (x);
-#else
-#define atanh scm_atanh
- return 0.5 * log ((1 + x) / (1 - x));
-#endif
-}
-SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh);
-/* "Return the inverse hyperbolic tangent of @var{x}."
- */
-
-
double
scm_c_truncate (double x)
{
}
#undef FUNC_NAME
-SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
-/* "Return the square root of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
-/* "Return the absolute value of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
-/* "Return the @var{x}th power of e."
- */
-SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
-/* "Return the natural logarithm of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
-/* "Return the sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
-/* "Return the cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
-/* "Return the tangent of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
-/* "Return the arc sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
-/* "Return the arc cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
-/* "Return the arc tangent of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
-/* "Return the hyperbolic sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
-/* "Return the hyperbolic cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
-/* "Return the hyperbolic tangent of the real number @var{x}."
- */
+/* sin/cos/tan/asin/acos/atan
+ sinh/cosh/tanh/asinh/acosh/atanh
+ Derived from "Transcen.scm", Complex trancendental functions for SCM.
+ Written by Jerry D. Hedden, (C) FSF.
+ See the file `COPYING' for terms applying to this program. */
-struct dpair
+SCM_DEFINE (scm_expt, "expt", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return @var{x} raised to the power of @var{y}.")
+#define FUNC_NAME s_scm_expt
{
- double x, y;
-};
+ if (!SCM_INEXACTP (y) && scm_is_integer (y))
+ return scm_integer_expt (x, y);
+ else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
+ {
+ return scm_from_double (pow (scm_to_double (x), scm_to_double (y)));
+ }
+ else
+ return scm_exp (scm_product (scm_log (x), y));
+}
+#undef FUNC_NAME
-static void scm_two_doubles (SCM x,
- SCM y,
- const char *sstring,
- struct dpair * xy);
+SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0,
+ (SCM z),
+ "Compute the sine of @var{z}.")
+#define FUNC_NAME s_scm_sin
+{
+ if (scm_is_real (z))
+ return scm_from_double (sin (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (sin (x) * cosh (y),
+ cos (x) * sinh (y));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sin, z, 1, s_scm_sin);
+}
+#undef FUNC_NAME
-static void
-scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
+SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0,
+ (SCM z),
+ "Compute the cosine of @var{z}.")
+#define FUNC_NAME s_scm_cos
{
- if (SCM_I_INUMP (x))
- xy->x = SCM_I_INUM (x);
- else if (SCM_BIGP (x))
- xy->x = scm_i_big2dbl (x);
- else if (SCM_REALP (x))
- xy->x = SCM_REAL_VALUE (x);
- else if (SCM_FRACTIONP (x))
- xy->x = scm_i_fraction2double (x);
+ if (scm_is_real (z))
+ return scm_from_double (cos (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (cos (x) * cosh (y),
+ -sin (x) * sinh (y));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_cos, z, 1, s_scm_cos);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0,
+ (SCM z),
+ "Compute the tangent of @var{z}.")
+#define FUNC_NAME s_scm_tan
+{
+ if (scm_is_real (z))
+ return scm_from_double (tan (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y, w;
+ x = 2.0 * SCM_COMPLEX_REAL (z);
+ y = 2.0 * SCM_COMPLEX_IMAG (z);
+ w = cos (x) + cosh (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (w == 0.0)
+ scm_num_overflow (s_scm_tan);
+#endif
+ return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_tan, z, 1, s_scm_tan);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic sine of @var{z}.")
+#define FUNC_NAME s_scm_sinh
+{
+ if (scm_is_real (z))
+ return scm_from_double (sinh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (sinh (x) * cos (y),
+ cosh (x) * sin (y));
+ }
else
- scm_wrong_type_arg (sstring, SCM_ARG1, x);
-
- if (SCM_I_INUMP (y))
- xy->y = SCM_I_INUM (y);
- else if (SCM_BIGP (y))
- xy->y = scm_i_big2dbl (y);
- else if (SCM_REALP (y))
- xy->y = SCM_REAL_VALUE (y);
- else if (SCM_FRACTIONP (y))
- xy->y = scm_i_fraction2double (y);
+ SCM_WTA_DISPATCH_1 (g_scm_sinh, z, 1, s_scm_sinh);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic cosine of @var{z}.")
+#define FUNC_NAME s_scm_cosh
+{
+ if (scm_is_real (z))
+ return scm_from_double (cosh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (cosh (x) * cos (y),
+ sinh (x) * sin (y));
+ }
else
- scm_wrong_type_arg (sstring, SCM_ARG2, y);
+ SCM_WTA_DISPATCH_1 (g_scm_cosh, z, 1, s_scm_cosh);
}
+#undef FUNC_NAME
+SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic tangent of @var{z}.")
+#define FUNC_NAME s_scm_tanh
+{
+ if (scm_is_real (z))
+ return scm_from_double (tanh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y, w;
+ x = 2.0 * SCM_COMPLEX_REAL (z);
+ y = 2.0 * SCM_COMPLEX_IMAG (z);
+ w = cosh (x) + cos (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (w == 0.0)
+ scm_num_overflow (s_scm_tanh);
+#endif
+ return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_tanh, z, 1, s_scm_tanh);
+}
+#undef FUNC_NAME
-SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
- (SCM x, SCM y),
- "Return @var{x} raised to the power of @var{y}. This\n"
- "procedure does not accept complex arguments.")
-#define FUNC_NAME s_scm_sys_expt
+SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0,
+ (SCM z),
+ "Compute the arc sine of @var{z}.")
+#define FUNC_NAME s_scm_asin
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_from_double (pow (xy.x, xy.y));
+ if (scm_is_real (z))
+ {
+ double w = scm_to_double (z);
+ if (w >= -1.0 && w <= 1.0)
+ return scm_from_double (asin (w));
+ else
+ return scm_product (scm_c_make_rectangular (0, -1),
+ scm_sys_asinh (scm_c_make_rectangular (0, w)));
+ }
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_product (scm_c_make_rectangular (0, -1),
+ scm_sys_asinh (scm_c_make_rectangular (-y, x)));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_asin, z, 1, s_scm_asin);
}
#undef FUNC_NAME
+SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0,
+ (SCM z),
+ "Compute the arc cosine of @var{z}.")
+#define FUNC_NAME s_scm_acos
+{
+ if (scm_is_real (z))
+ {
+ double w = scm_to_double (z);
+ if (w >= -1.0 && w <= 1.0)
+ return scm_from_double (acos (w));
+ else
+ return scm_sum (scm_from_double (acos (0.0)),
+ scm_product (scm_c_make_rectangular (0, 1),
+ scm_sys_asinh (scm_c_make_rectangular (0, w))));
+ }
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_sum (scm_from_double (acos (0.0)),
+ scm_product (scm_c_make_rectangular (0, 1),
+ scm_sys_asinh (scm_c_make_rectangular (-y, x))));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_acos, z, 1, s_scm_acos);
+}
+#undef FUNC_NAME
-SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
- (SCM x, SCM y),
- "Return the arc tangent of the two arguments @var{x} and\n"
- "@var{y}. This is similar to calculating the arc tangent of\n"
- "@var{x} / @var{y}, except that the signs of both arguments\n"
- "are used to determine the quadrant of the result. This\n"
- "procedure does not accept complex arguments.")
-#define FUNC_NAME s_scm_sys_atan2
+SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
+ (SCM z, SCM y),
+ "With one argument, compute the arc tangent of @var{z}.\n"
+ "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
+ "using the sign of @var{z} and @var{y} to determine the quadrant.")
+#define FUNC_NAME s_scm_atan
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_from_double (atan2 (xy.x, xy.y));
+ if (SCM_UNBNDP (y))
+ {
+ if (scm_is_real (z))
+ return scm_from_double (atan (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ {
+ double v, w;
+ v = SCM_COMPLEX_REAL (z);
+ w = SCM_COMPLEX_IMAG (z);
+ return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v, w - 1.0),
+ scm_c_make_rectangular (v, w + 1.0))),
+ scm_c_make_rectangular (0, 2));
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+ }
+ else if (scm_is_real (z))
+ {
+ if (scm_is_real (y))
+ return scm_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic sine of @var{z}.")
+#define FUNC_NAME s_scm_sys_asinh
+{
+ if (scm_is_real (z))
+ return scm_from_double (asinh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_log (scm_sum (z,
+ scm_sqrt (scm_sum (scm_product (z, z),
+ SCM_I_MAKINUM (1)))));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic cosine of @var{z}.")
+#define FUNC_NAME s_scm_sys_acosh
+{
+ if (scm_is_real (z) && scm_to_double (z) >= 1.0)
+ return scm_from_double (acosh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_log (scm_sum (z,
+ scm_sqrt (scm_difference (scm_product (z, z),
+ SCM_I_MAKINUM (1)))));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic tangent of @var{z}.")
+#define FUNC_NAME s_scm_sys_atanh
+{
+ if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
+ return scm_from_double (atanh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_divide (scm_log (scm_divide (scm_sum (SCM_I_MAKINUM (1), z),
+ scm_difference (SCM_I_MAKINUM (1), z))),
+ SCM_I_MAKINUM (2));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
}
#undef FUNC_NAME
else
{
SCM z;
- SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex),
- "complex"));
+ SCM_NEWSMOB (z, scm_tc16_complex,
+ scm_gc_malloc_pointerless (sizeof (scm_t_complex),
+ "complex"));
SCM_COMPLEX_REAL (z) = re;
SCM_COMPLEX_IMAG (z) = im;
return z;
"and @var{imaginary-part} parts.")
#define FUNC_NAME s_scm_make_rectangular
{
- struct dpair xy;
- scm_two_doubles (real_part, imaginary_part, FUNC_NAME, &xy);
- return scm_c_make_rectangular (xy.x, xy.y);
+ SCM_ASSERT_TYPE (scm_is_real (real_part), real_part,
+ SCM_ARG1, FUNC_NAME, "real");
+ SCM_ASSERT_TYPE (scm_is_real (imaginary_part), imaginary_part,
+ SCM_ARG2, FUNC_NAME, "real");
+ return scm_c_make_rectangular (scm_to_double (real_part),
+ scm_to_double (imaginary_part));
}
#undef FUNC_NAME
"Return the complex number @var{x} * e^(i * @var{y}).")
#define FUNC_NAME s_scm_make_polar
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_c_make_polar (xy.x, xy.y);
+ SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real");
+ SCM_ASSERT_TYPE (scm_is_real (y), y, SCM_ARG2, FUNC_NAME, "real");
+ return scm_c_make_polar (scm_to_double (x), scm_to_double (y));
}
#undef FUNC_NAME
else if (SCM_BIGP (z))
return SCM_INUM0;
else if (SCM_REALP (z))
- return scm_flo0;
+ return flo0;
else if (SCM_COMPLEXP (z))
return scm_from_double (SCM_COMPLEX_IMAG (z));
else if (SCM_FRACTIONP (z))
scm_angle (SCM z)
{
/* atan(0,-1) is pi and it'd be possible to have that as a constant like
- scm_flo0 to save allocating a new flonum with scm_from_double each time.
+ flo0 to save allocating a new flonum with scm_from_double each time.
But if atan2 follows the floating point rounding mode, then the value
is not a constant. Maybe it'd be close enough though. */
if (SCM_I_INUMP (z))
{
if (SCM_I_INUM (z) >= 0)
- return scm_flo0;
+ return flo0;
else
return scm_from_double (atan2 (0.0, -1.0));
}
if (sgn < 0)
return scm_from_double (atan2 (0.0, -1.0));
else
- return scm_flo0;
+ return flo0;
}
else if (SCM_REALP (z))
{
if (SCM_REAL_VALUE (z) >= 0)
- return scm_flo0;
+ return flo0;
else
return scm_from_double (atan2 (0.0, -1.0));
}
else if (SCM_FRACTIONP (z))
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
- return scm_flo0;
+ return flo0;
else return scm_from_double (atan2 (0.0, -1.0));
}
else
scm_add_feature ("complex");
scm_add_feature ("inexact");
- scm_flo0 = scm_from_double (0.0);
+ flo0 = scm_from_double (0.0);
/* determine floating point precision */
for (i=2; i <= SCM_MAX_DBL_RADIX; ++i)
}
#ifdef DBL_DIG
/* hard code precision for base 10 if the preprocessor tells us to... */
- scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
+ scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
#endif
- exactly_one_half = scm_permanent_object (scm_divide (SCM_I_MAKINUM (1),
- SCM_I_MAKINUM (2)));
+ exactly_one_half = scm_divide (SCM_I_MAKINUM (1), SCM_I_MAKINUM (2));
#include "libguile/numbers.x"
}
SCM_API SCM scm_logcount (SCM n);
SCM_API SCM scm_integer_length (SCM n);
+SCM_INTERNAL SCM scm_i_gcd (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_lcm (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_logand (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_logior (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_logxor (SCM x, SCM y, SCM rest);
+
SCM_API size_t scm_iint2str (scm_t_intmax num, int rad, char *p);
SCM_API size_t scm_iuint2str (scm_t_uintmax num, int rad, char *p);
SCM_API SCM scm_number_to_string (SCM x, SCM radix);
SCM_API SCM scm_divide (SCM x, SCM y);
SCM_API SCM scm_floor (SCM x);
SCM_API SCM scm_ceiling (SCM x);
-SCM_API double scm_asinh (double x);
-SCM_API double scm_acosh (double x);
-SCM_API double scm_atanh (double x);
SCM_API double scm_c_truncate (double x);
SCM_API double scm_c_round (double x);
SCM_API SCM scm_truncate_number (SCM x);
SCM_API SCM scm_round_number (SCM x);
-SCM_API SCM scm_sys_expt (SCM z1, SCM z2);
-SCM_API SCM scm_sys_atan2 (SCM z1, SCM z2);
+SCM_API SCM scm_expt (SCM z1, SCM z2);
+SCM_API SCM scm_sin (SCM z);
+SCM_API SCM scm_cos (SCM z);
+SCM_API SCM scm_tan (SCM z);
+SCM_API SCM scm_sinh (SCM z);
+SCM_API SCM scm_cosh (SCM z);
+SCM_API SCM scm_tanh (SCM z);
+SCM_API SCM scm_asin (SCM z);
+SCM_API SCM scm_acos (SCM z);
+SCM_API SCM scm_atan (SCM x, SCM y);
+SCM_API SCM scm_sys_asinh (SCM z);
+SCM_API SCM scm_sys_acosh (SCM z);
+SCM_API SCM scm_sys_atanh (SCM z);
SCM_API SCM scm_make_rectangular (SCM z1, SCM z2);
SCM_API SCM scm_make_polar (SCM z1, SCM z2);
SCM_API SCM scm_real_part (SCM z);
SCM_API SCM scm_exp (SCM z);
SCM_API SCM scm_sqrt (SCM z);
+SCM_INTERNAL SCM scm_i_min (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_max (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_sum (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_difference (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_product (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_divide (SCM x, SCM y, SCM rest);
+
/* bignum internal functions */
SCM_INTERNAL SCM scm_i_mkbig (void);
SCM_API /* FIXME: not internal */ SCM scm_i_normbig (SCM x);
#include <sys/stat.h>
#include <sys/types.h>
#include <assert.h>
+#include <alignof.h>
#include "_scm.h"
#include "vm-bootstrap.h"
scm_from_uint32 (parent_data->len),
scm_from_uint32 (parent_data->metalen)));
-#ifdef __GNUC__ /* we need `__alignof__' */
/* Make sure bytecode for the objcode-meta is suitable aligned. Failing to
do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */
- assert ((((scm_t_bits) ptr) & (__alignof__ (struct scm_objcode) - 1UL)) == 0);
-#endif
+ assert ((((scm_t_bits) ptr) &
+ (alignof_type (struct scm_objcode) - 1UL)) == 0);
data = (struct scm_objcode*)ptr;
if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
}
#undef FUNC_NAME
-static SCM
-objcode_mark (SCM obj)
-{
- return SCM_SMOB_OBJECT_2 (obj);
-}
-
\f
/*
* Scheme interface
"")
#define FUNC_NAME s_scm_objcode_p
{
- return SCM_BOOL (SCM_OBJCODE_P (obj));
+ return scm_from_bool (SCM_OBJCODE_P (obj));
}
#undef FUNC_NAME
SCM_VALIDATE_OBJCODE (1, objcode);
len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
- /* FIXME: Is `gc_malloc' ok here? */
- u8vector = scm_gc_malloc (len, "objcode-u8vector");
+
+ u8vector = scm_malloc (len);
memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
return scm_take_u8vector (u8vector, len);
scm_bootstrap_objcodes (void)
{
scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
- scm_set_smob_mark (scm_tc16_objcode, objcode_mark);
scm_c_register_extension ("libguile", "scm_init_objcodes",
(scm_t_extension_init_func)scm_init_objcodes, NULL);
}
/* objcode data should be directly mappable to this C structure. */
struct scm_objcode {
- scm_t_uint8 nargs;
- scm_t_uint8 nrest;
- scm_t_uint16 nlocs;
scm_t_uint32 len; /* the maximum index of base[] */
scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of
base[] for metadata */
- scm_t_uint32 unused; /* pad so that `base' is 8-byte aligned */
scm_t_uint8 base[0];
};
#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
#define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen)
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x))
-#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs)
-#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest)
-#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs)
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
+++ /dev/null
-/* Copyright (C) 1995,1996,1999,2000,2001, 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
- */
-
-
-\f
-
-/* This file and objects.h contains those minimal pieces of the Guile
- * Object Oriented Programming System which need to be included in
- * libguile. See the comments in objects.h.
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/_scm.h"
-
-#include "libguile/struct.h"
-#include "libguile/procprop.h"
-#include "libguile/chars.h"
-#include "libguile/keywords.h"
-#include "libguile/smob.h"
-#include "libguile/eval.h"
-#include "libguile/alist.h"
-#include "libguile/ports.h"
-#include "libguile/strings.h"
-#include "libguile/vectors.h"
-#include "libguile/programs.h"
-#include "libguile/vm.h"
-
-#include "libguile/validate.h"
-#include "libguile/objects.h"
-#include "libguile/goops.h"
-
-\f
-
-SCM scm_metaclass_standard;
-SCM scm_metaclass_operator;
-
-/* The cache argument for scm_mcache_lookup_cmethod has one of two possible
- * formats:
- *
- * Format #1:
- * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
- * #((TYPE1 ... ENV FORMALS FORM ...) ...)
- * GF)
- *
- * Format #2:
- * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
- * #((TYPE1 ... ENV FORMALS FORM ...) ...)
- * GF)
- *
- * ARGS is either a list of expressions, in which case they
- * are interpreted as the arguments of an application, or
- * a non-pair, which is interpreted as a single expression
- * yielding all arguments.
- *
- * SCM_IM_DISPATCH expressions in generic functions always
- * have ARGS = the symbol `args' or the iloc #@0-0.
- *
- * Need FORMALS in order to support varying arity. This
- * also avoids the need for renaming of bindings.
- *
- * We should probably not complicate this mechanism by
- * introducing "optimizations" for getters and setters or
- * primitive methods. Getters and setter will normally be
- * compiled into @slot-[ref|set!] or a procedure call.
- * They rely on the dispatch performed before executing
- * the code which contains them.
- *
- * We might want to use a more efficient representation of
- * this form in the future, perhaps after we have introduced
- * low-level support for syntax-case macros.
- */
-
-SCM
-scm_mcache_lookup_cmethod (SCM cache, SCM args)
-{
- unsigned long i, mask, n, end;
- SCM ls, methods, z = SCM_CDDR (cache);
- n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
- methods = SCM_CADR (z);
-
- if (scm_is_simple_vector (methods))
- {
- /* cache format #1: prepare for linear search */
- mask = -1;
- i = 0;
- end = SCM_SIMPLE_VECTOR_LENGTH (methods);
- }
- else
- {
- /* cache format #2: compute a hash value */
- unsigned long hashset = scm_to_ulong (methods);
- long j = n;
- z = SCM_CDDR (z);
- mask = scm_to_ulong (SCM_CAR (z));
- methods = SCM_CADR (z);
- i = 0;
- ls = args;
- if (!scm_is_null (ls))
- do
- {
- i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
- [scm_si_hashsets + hashset];
- ls = SCM_CDR (ls);
- }
- while (j-- && !scm_is_null (ls));
- i &= mask;
- end = i;
- }
-
- /* Search for match */
- do
- {
- long j = n;
- z = SCM_SIMPLE_VECTOR_REF (methods, i);
- ls = args; /* list of arguments */
- if (!scm_is_null (ls))
- do
- {
- /* More arguments than specifiers => CLASS != ENV */
- if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
- goto next_method;
- ls = SCM_CDR (ls);
- z = SCM_CDR (z);
- }
- while (j-- && !scm_is_null (ls));
- /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */
- if (!scm_is_pair (z)
- || (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z))))
- return z;
- next_method:
- i = (i + 1) & mask;
- } while (i != end);
- return SCM_BOOL_F;
-}
-
-SCM
-scm_mcache_compute_cmethod (SCM cache, SCM args)
-{
- SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
- if (scm_is_false (cmethod))
- /* No match - memoize */
- return scm_memoize_method (cache, args);
- return cmethod;
-}
-
-SCM
-scm_apply_generic (SCM gf, SCM args)
-{
- SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
- if (SCM_PROGRAM_P (cmethod))
- return scm_vm_apply (scm_the_vm (), cmethod, args);
- else if (scm_is_pair (cmethod))
- return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
- SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
- args,
- SCM_CMETHOD_ENV (cmethod)));
- else
- return scm_apply (cmethod, args, SCM_EOL);
-}
-
-SCM
-scm_call_generic_0 (SCM gf)
-{
- return scm_apply_generic (gf, SCM_EOL);
-}
-
-SCM
-scm_call_generic_1 (SCM gf, SCM a1)
-{
- return scm_apply_generic (gf, scm_list_1 (a1));
-}
-
-SCM
-scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
-{
- return scm_apply_generic (gf, scm_list_2 (a1, a2));
-}
-
-SCM
-scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
-{
- return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
-}
-
-SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is an entity.")
-#define FUNC_NAME s_scm_entity_p
-{
- return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is an operator.")
-#define FUNC_NAME s_scm_operator_p
-{
- return scm_from_bool(SCM_STRUCTP (obj)
- && SCM_I_OPERATORP (obj)
- && !SCM_I_ENTITYP (obj));
-}
-#undef FUNC_NAME
-
-/* XXX - What code requires the object procedure to be only of certain
- types? */
-
-SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
- (SCM proc),
- "Return @code{#t} iff @var{proc} is a procedure that can be used "
- "with @code{set-object-procedure}. It is always valid to use "
- "a closure constructed by @code{lambda}.")
-#define FUNC_NAME s_scm_valid_object_procedure_p
-{
- if (SCM_IMP (proc))
- return SCM_BOOL_F;
- switch (SCM_TYP7 (proc))
- {
- default:
- return SCM_BOOL_F;
- case scm_tcs_closures:
- case scm_tc7_subr_1:
- case scm_tc7_subr_2:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- return SCM_BOOL_T;
- }
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
- (SCM obj, SCM proc),
- "Set the object procedure of @var{obj} to @var{proc}.\n"
- "@var{obj} must be either an entity or an operator.")
-#define FUNC_NAME s_scm_set_object_procedure_x
-{
- SCM_ASSERT (SCM_STRUCTP (obj)
- && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
- || (SCM_I_ENTITYP (obj)
- && !(SCM_OBJ_CLASS_FLAGS (obj)
- & SCM_CLASSF_PURE_GENERIC))),
- obj,
- SCM_ARG1,
- FUNC_NAME);
- SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME);
- if (SCM_I_ENTITYP (obj))
- SCM_SET_ENTITY_PROCEDURE (obj, proc);
- else
- SCM_OPERATOR_CLASS (obj)->procedure = proc;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#ifdef GUILE_DEBUG
-SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0,
- (SCM obj),
- "Return the object procedure of @var{obj}. @var{obj} must be\n"
- "an entity or an operator.")
-#define FUNC_NAME s_scm_object_procedure
-{
- SCM_ASSERT (SCM_STRUCTP (obj)
- && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
- || SCM_I_ENTITYP (obj)),
- obj, SCM_ARG1, FUNC_NAME);
- return (SCM_I_ENTITYP (obj)
- ? SCM_ENTITY_PROCEDURE (obj)
- : SCM_OPERATOR_CLASS (obj)->procedure);
-}
-#undef FUNC_NAME
-#endif /* GUILE_DEBUG */
-
-/* The following procedures are not a part of Goops but a minimal
- * object system built upon structs. They are here for those who
- * want to implement their own object system.
- */
-
-SCM
-scm_i_make_class_object (SCM meta,
- SCM layout_string,
- unsigned long flags)
-{
- SCM c;
- SCM layout = scm_make_struct_layout (layout_string);
- c = scm_make_struct (meta,
- SCM_INUM0,
- scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
- SCM_SET_CLASS_FLAGS (c, flags);
- return c;
-}
-
-SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0,
- (SCM metaclass, SCM layout),
- "Create a new class object of class @var{metaclass}, with the\n"
- "slot layout specified by @var{layout}.")
-#define FUNC_NAME s_scm_make_class_object
-{
- unsigned long flags = 0;
- SCM_VALIDATE_STRUCT (1, metaclass);
- SCM_VALIDATE_STRING (2, layout);
- if (scm_is_eq (metaclass, scm_metaclass_operator))
- flags = SCM_CLASSF_OPERATOR;
- return scm_i_make_class_object (metaclass, layout, flags);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0,
- (SCM class, SCM layout),
- "Create a subclass object of @var{class}, with the slot layout\n"
- "specified by @var{layout}.")
-#define FUNC_NAME s_scm_make_subclass_object
-{
- SCM pl;
- SCM_VALIDATE_STRUCT (1, class);
- SCM_VALIDATE_STRING (2, layout);
- pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]);
- pl = scm_symbol_to_string (pl);
- return scm_i_make_class_object (SCM_STRUCT_VTABLE (class),
- scm_string_append (scm_list_2 (pl, layout)),
- SCM_CLASS_FLAGS (class));
-}
-#undef FUNC_NAME
-
-void
-scm_init_objects ()
-{
- SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT);
- SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0,
- scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
-
- SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT);
- SCM ot = scm_make_vtable_vtable (os, SCM_INUM0,
- scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
-
- SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT);
- SCM el = scm_make_struct_layout (es);
- SCM et = scm_make_struct (mt, SCM_INUM0,
- scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));
-
- scm_c_define ("<class>", mt);
- scm_metaclass_standard = mt;
- scm_c_define ("<operator-class>", ot);
- scm_metaclass_operator = ot;
- SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
- SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity);
- scm_c_define ("<entity>", et);
-
-#include "libguile/objects.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* classes: h_files */
-
-#ifndef SCM_OBJECTS_H
-#define SCM_OBJECTS_H
-
-/* Copyright (C) 1996,1999,2000,2001, 2003, 2006, 2008, 2009 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
- */
-
-\f
-
-/* This file and objects.c contains those minimal pieces of the Guile
- * Object Oriented Programming System which need to be included in
- * libguile.
- *
- * {Objects and structs}
- *
- * Objects are currently based upon structs. Although the struct
- * implementation will change thoroughly in the future, objects will
- * still be based upon structs.
- */
-
-#include "libguile/__scm.h"
-#include "libguile/struct.h"
-
-\f
-
-/* {Class flags}
- *
- * These are used for efficient identification of instances of a
- * certain class or its subclasses when traversal of the inheritance
- * graph would be too costly.
- */
-#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class) [scm_struct_i_flags])
-#define SCM_OBJ_CLASS_FLAGS(obj) (SCM_STRUCT_VTABLE_DATA (obj) [scm_struct_i_flags])
-#define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
-#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
-#define SCM_CLASSF_MASK SCM_STRUCTF_MASK
-
-#define SCM_CLASSF_ENTITY SCM_STRUCTF_ENTITY
-/* Operator classes need to be identified in the evaluator.
- (Entities also have SCM_CLASSF_OPERATOR set in their vtable.) */
-#define SCM_CLASSF_OPERATOR (1L << 29)
-
-#define SCM_I_OPERATORP(obj)\
- ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0)
-#define SCM_OPERATOR_CLASS(obj)\
-((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj))
-#define SCM_OBJ_OPERATOR_CLASS(obj)\
-((struct scm_metaclass_operator *) SCM_STRUCT_VTABLE_DATA (obj))
-#define SCM_OPERATOR_PROCEDURE(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->procedure)
-#define SCM_OPERATOR_SETTER(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->setter)
-
-#define SCM_I_ENTITYP(obj)\
- ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
-#define SCM_ENTITY_PROCEDURE(obj) \
- (SCM_PACK (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure]))
-#define SCM_SET_ENTITY_PROCEDURE(obj, v) \
- (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure] = SCM_UNPACK (v))
-#define SCM_ENTITY_SETTER(obj) (SCM_PACK (SCM_STRUCT_DATA (obj)[scm_struct_i_setter]))
-#define SCM_SET_ENTITY_SETTER(obj, v) \
- (SCM_STRUCT_DATA (obj) [scm_struct_i_setter] = SCM_UNPACK (v))
-
-#define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
-#define SCM_SET_CLASS_INSTANCE_SIZE(c, s) \
- (SCM_STRUCT_DATA (c)[scm_struct_i_size] \
- = (SCM_STRUCT_DATA (c) [scm_struct_i_size] & SCM_STRUCTF_MASK) | s)
-
-/* {Operator classes}
- *
- * Instances of operator classes can work as operators, i. e., they
- * can be applied to arguments just as if they were ordinary
- * procedures.
- *
- * For instances of operator classes, the procedures to be applied are
- * stored in four dedicated slots in the associated class object.
- * Which one is selected depends on the number of arguments in the
- * application.
- *
- * If zero arguments are passed, the first will be selected.
- * If one argument is passed, the second will be selected.
- * If two arguments are passed, the third will be selected.
- * If three or more arguments are passed, the fourth will be selected.
- *
- * This is complicated and may seem gratuitous but has to do with the
- * architecture of the evaluator. Using only one procedure would
- * result in a great deal less efficient application, loss of
- * tail-recursion and would be difficult to reconcile with the
- * debugging evaluator.
- *
- * Also, using this "forked" application in low-level code has the
- * advantage of speeding up some code. An example is method dispatch
- * for generic operators applied to few arguments. On the user level,
- * the "forked" application will be hidden by mechanisms in the GOOPS
- * package.
- *
- * Operator classes have the metaclass <operator-metaclass>.
- *
- * An example of an operator class is the class <tk-command>.
- */
-#define SCM_METACLASS_STANDARD_LAYOUT ""
-struct scm_metaclass_standard {
- SCM layout;
- SCM vcell;
- SCM vtable;
- SCM print;
-};
-
-#define SCM_METACLASS_OPERATOR_LAYOUT "popo"
-struct scm_metaclass_operator {
- SCM layout;
- SCM vcell;
- SCM vtable;
- SCM print;
- SCM procedure;
- SCM setter;
-};
-
-/* {Entity classes}
- *
- * For instances of entity classes (entities), the procedures to be
- * applied are stored in the instance itself rather than in the class
- * object as is the case for instances of operator classes (see above).
- *
- * An example of an entity class is the class of generic methods.
- */
-#define SCM_ENTITY_LAYOUT ""
-
-/* {Interface to Goops}
- *
- * The evaluator contains a multi-method dispatch mechanism.
- * This interface is used by that mechanism and during creation of
- * smob and struct classes.
- */
-
-/* Internal representation of Goops objects. */
-#define SCM_CLASSF_PURE_GENERIC (0x010 << 20)
-#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
-#define SCM_CLASSF_GOOPS (0x100 << 20)
-#define scm_si_redefined 5
-#define scm_si_hashsets 6
-#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
-#define SCM_OBJ_CLASS_REDEF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x) [scm_si_redefined]))
-
-typedef struct scm_effective_slot_definition {
- SCM name;
- long location;
- SCM init_value;
- SCM (*get) (SCM obj, SCM slotdef);
- SCM (*set) (SCM obj, SCM slotdef, SCM value);
-} scm_effective_slot_definition;
-
-#define SCM_ESLOTDEF(x) ((scm_effective_slot_definition *) SCM_CDR (x))
-
-#define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod)
-#define SCM_CMETHOD_FORMALS(cmethod) SCM_CAR (SCM_CMETHOD_CODE (cmethod))
-#define SCM_CMETHOD_BODY(cmethod) SCM_CDR (SCM_CMETHOD_CODE (cmethod))
-#define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod)
-
-/* Port classes */
-#define SCM_IN_PCLASS_INDEX 0
-#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
-#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
-
-/* Plugin proxy classes for basic types. */
-SCM_API SCM scm_metaclass_standard;
-SCM_API SCM scm_metaclass_operator;
-
-/* Goops functions. */
-SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep);
-SCM_INTERNAL void scm_i_inherit_applicable (SCM c);
-SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
-SCM_API void scm_change_object_class (SCM, SCM, SCM);
-SCM_API SCM scm_memoize_method (SCM x, SCM args);
-
-SCM_API SCM scm_mcache_lookup_cmethod (SCM cache, SCM args);
-SCM_API SCM scm_mcache_compute_cmethod (SCM cache, SCM args);
-/* The following are declared in __scm.h
-SCM_API SCM scm_call_generic_0 (SCM gf);
-SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
-SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
-SCM_API SCM scm_apply_generic (SCM gf, SCM args);
-*/
-SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
-SCM_API SCM scm_entity_p (SCM obj);
-SCM_API SCM scm_operator_p (SCM obj);
-SCM_API SCM scm_valid_object_procedure_p (SCM proc);
-SCM_API SCM scm_set_object_procedure_x (SCM obj, SCM proc);
-#ifdef GUILE_DEBUG
-SCM_API SCM scm_object_procedure (SCM obj);
-#endif
-SCM_API SCM scm_make_class_object (SCM metaclass, SCM layout);
-SCM_API SCM scm_make_subclass_object (SCM c, SCM layout);
-
-SCM_INTERNAL SCM scm_i_make_class_object (SCM metaclass, SCM layout_string,
- unsigned long flags);
-SCM_INTERNAL void scm_init_objects (void);
-
-#endif /* SCM_OBJECTS_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
-/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008, 2009 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
/* {Object Properties}
*/
+static SCM object_whash;
+
SCM_DEFINE (scm_object_properties, "object-properties", 1, 0, 0,
(SCM obj),
"Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_object_properties
{
- return scm_hashq_ref (scm_object_whash, obj, SCM_EOL);
+ return scm_hashq_ref (object_whash, obj, SCM_EOL);
}
#undef FUNC_NAME
"Set @var{obj}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_object_properties_x
{
- SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, alist);
+ SCM handle = scm_hashq_create_handle_x (object_whash, obj, alist);
SCM_SETCDR (handle, alist);
return alist;
}
{
SCM h;
SCM assoc;
- h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
+ h = scm_hashq_create_handle_x (object_whash, obj, SCM_EOL);
SCM_CRITICAL_SECTION_START;
assoc = scm_assq (key, SCM_CDR (h));
if (SCM_NIMP (assoc))
void
scm_init_objprop ()
{
- scm_object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/objprop.x"
}
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
{
SCM name = scm_from_locale_symbol (options[i].name);
options[i].name = (char *) SCM_UNPACK (name);
- scm_permanent_object (name);
}
func (SCM_UNDEFINED);
}
-/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009 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
#include "libguile/pairs.h"
+#include "verify.h"
+
\f
/* {Pairs}
*/
+/*
+ * This compile-time test verifies the properties needed for the
+ * efficient test macro scm_is_null_or_nil defined in pairs.h,
+ * which is defined in terms of the SCM_MATCHES_BITS_IN_COMMON macro.
+ *
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
+ */
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL, SCM_EOL));
+
+
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
#include "libguile/ports.h"
}
#undef FUNC_NAME
-SCM
-scm_car (SCM pair)
-{
- if (!scm_is_pair (pair))
- scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
- return SCM_CAR (pair);
-}
-
-SCM
-scm_cdr (SCM pair)
-{
- if (!scm_is_pair (pair))
- scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
- return SCM_CDR (pair);
-}
-
-SCM
-scm_i_chase_pairs (SCM tree, scm_t_uint32 pattern)
-{
- do
- {
- if (!scm_is_pair (tree))
- scm_wrong_type_arg_msg (NULL, 0, tree, "pair");
- tree = (pattern & 1) ? SCM_CAR (tree) : SCM_CDR (tree);
- pattern >>= 2;
- }
- while (pattern);
- return tree;
-}
-
SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
(SCM pair, SCM value),
"Stores @var{value} in the car field of @var{pair}. The value returned\n"
* two bits is only needed to indicate when cxr-ing is ready. This is the
* case, when all remaining pairs of bits equal 00. */
-typedef struct {
- const char *name;
- unsigned char pattern;
-} t_cxr;
-
-static const t_cxr cxrs[] =
-{
- {"cdr", 0x02}, /* 00000010 */
- {"car", 0x03}, /* 00000011 */
- {"cddr", 0x0a}, /* 00001010 */
- {"cdar", 0x0b}, /* 00001011 */
- {"cadr", 0x0e}, /* 00001110 */
- {"caar", 0x0f}, /* 00001111 */
- {"cdddr", 0x2a}, /* 00101010 */
- {"cddar", 0x2b}, /* 00101011 */
- {"cdadr", 0x2e}, /* 00101110 */
- {"cdaar", 0x2f}, /* 00101111 */
- {"caddr", 0x3a}, /* 00111010 */
- {"cadar", 0x3b}, /* 00111011 */
- {"caadr", 0x3e}, /* 00111110 */
- {"caaar", 0x3f}, /* 00111111 */
- {"cddddr", 0xaa}, /* 10101010 */
- {"cdddar", 0xab}, /* 10101011 */
- {"cddadr", 0xae}, /* 10101110 */
- {"cddaar", 0xaf}, /* 10101111 */
- {"cdaddr", 0xba}, /* 10111010 */
- {"cdadar", 0xbb}, /* 10111011 */
- {"cdaadr", 0xbe}, /* 10111110 */
- {"cdaaar", 0xbf}, /* 10111111 */
- {"cadddr", 0xea}, /* 11101010 */
- {"caddar", 0xeb}, /* 11101011 */
- {"cadadr", 0xee}, /* 11101110 */
- {"cadaar", 0xef}, /* 11101111 */
- {"caaddr", 0xfa}, /* 11111010 */
- {"caadar", 0xfb}, /* 11111011 */
- {"caaadr", 0xfe}, /* 11111110 */
- {"caaaar", 0xff}, /* 11111111 */
- {0, 0}
-};
+/* The compiler should unroll this. */
+#define CHASE_PAIRS(tree, FUNC_NAME, pattern) \
+ scm_t_uint32 pattern_var = pattern; \
+ do \
+ { \
+ if (!scm_is_pair (tree)) \
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, tree, "pair"); \
+ tree = (pattern_var & 1) ? SCM_CAR (tree) : SCM_CDR (tree); \
+ pattern_var >>= 2; \
+ } \
+ while (pattern_var); \
+ return tree
+
+
+SCM_DEFINE (scm_cdr, "cdr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdr", 0x02); /* 00000010 */
+}
+SCM_DEFINE (scm_car, "car", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "car", 0x03); /* 00000011 */
+}
+SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddr", 0x0a); /* 00001010 */
+}
+SCM_DEFINE (scm_cdar, "cdar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdar", 0x0b); /* 00001011 */
+}
+SCM_DEFINE (scm_cadr, "cadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadr", 0x0e); /* 00001110 */
+}
+SCM_DEFINE (scm_caar, "caar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caar", 0x0f); /* 00001111 */
+}
+SCM_DEFINE (scm_cdddr, "cdddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdddr", 0x2a); /* 00101010 */
+}
+SCM_DEFINE (scm_cddar, "cddar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddar", 0x2b); /* 00101011 */
+}
+SCM_DEFINE (scm_cdadr, "cdadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdadr", 0x2e); /* 00101110 */
+}
+SCM_DEFINE (scm_cdaar, "cdaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdaar", 0x2f); /* 00101111 */
+}
+SCM_DEFINE (scm_caddr, "caddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caddr", 0x3a); /* 00111010 */
+}
+SCM_DEFINE (scm_cadar, "cadar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadar", 0x3b); /* 00111011 */
+}
+SCM_DEFINE (scm_caadr, "caadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caadr", 0x3e); /* 00111110 */
+}
+SCM_DEFINE (scm_caaar, "caaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caaar", 0x3f); /* 00111111 */
+}
+SCM_DEFINE (scm_cddddr, "cddddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddddr", 0xaa); /* 10101010 */
+}
+SCM_DEFINE (scm_cdddar, "cdddar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdddar", 0xab); /* 10101011 */
+}
+SCM_DEFINE (scm_cddadr, "cddadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddadr", 0xae); /* 10101110 */
+}
+SCM_DEFINE (scm_cddaar, "cddaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddaar", 0xaf); /* 10101111 */
+}
+SCM_DEFINE (scm_cdaddr, "cdaddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdaddr", 0xba); /* 10111010 */
+}
+SCM_DEFINE (scm_cdadar, "cdadar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdadar", 0xbb); /* 10111011 */
+}
+SCM_DEFINE (scm_cdaadr, "cdaadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdaadr", 0xbe); /* 10111110 */
+}
+SCM_DEFINE (scm_cdaaar, "cdaaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdaaar", 0xbf); /* 10111111 */
+}
+SCM_DEFINE (scm_cadddr, "cadddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadddr", 0xea); /* 11101010 */
+}
+SCM_DEFINE (scm_caddar, "caddar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caddar", 0xeb); /* 11101011 */
+}
+SCM_DEFINE (scm_cadadr, "cadadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadadr", 0xee); /* 11101110 */
+}
+SCM_DEFINE (scm_cadaar, "cadaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadaar", 0xef); /* 11101111 */
+}
+SCM_DEFINE (scm_caaddr, "caaddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caaddr", 0xfa); /* 11111010 */
+}
+SCM_DEFINE (scm_caadar, "caadar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caadar", 0xfb); /* 11111011 */
+}
+SCM_DEFINE (scm_caaadr, "caaadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caaadr", 0xfe); /* 11111110 */
+}
+SCM_DEFINE (scm_caaaar, "caaaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caaaar", 0xff); /* 11111111 */
+}
\f
void
scm_init_pairs ()
{
- unsigned int subnr = 0;
-
- for (subnr = 0; cxrs[subnr].name; subnr++)
- {
- SCM (*pattern) () = (SCM (*) ()) (scm_t_bits) cxrs[subnr].pattern;
- scm_c_define_subr (cxrs[subnr].name, scm_tc7_cxr, pattern);
- }
-
#include "libguile/pairs.x"
}
#ifndef SCM_PAIRS_H
#define SCM_PAIRS_H
-/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008, 2009 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
# define SCM_VALIDATE_PAIR(cell, expr) (expr)
#endif
-#define scm_is_null(x) (scm_is_eq ((x), SCM_EOL))
+/*
+ * Use scm_is_null_and_not_nil if it's important (for correctness)
+ * that %nil must NOT be considered null.
+ */
+#define scm_is_null_and_not_nil(x) (scm_is_eq ((x), SCM_EOL))
+
+/*
+ * Use scm_is_null_assume_not_nil if %nil will never be tested,
+ * for increased efficiency.
+ */
+#define scm_is_null_assume_not_nil(x) (scm_is_eq ((x), SCM_EOL))
+
+/*
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information on
+ * how the following macro works.
+ */
+#if SCM_ENABLE_ELISP
+# define scm_is_null_or_nil(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_EOL))
+#else
+# define scm_is_null_or_nil(x) (scm_is_null_assume_not_nil (x))
+#endif
+
+/* XXX Should scm_is_null treat %nil as null by default? */
+#define scm_is_null(x) (scm_is_null_and_not_nil(x))
#define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x)))
#define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x)))
SCM_API SCM scm_set_car_x (SCM pair, SCM value);
SCM_API SCM scm_set_cdr_x (SCM pair, SCM value);
-#define SCM_I_D_PAT 0x02 /* 00000010 */
-#define SCM_I_A_PAT 0x03 /* 00000011 */
-#define SCM_I_DD_PAT 0x0a /* 00001010 */
-#define SCM_I_DA_PAT 0x0b /* 00001011 */
-#define SCM_I_AD_PAT 0x0e /* 00001110 */
-#define SCM_I_AA_PAT 0x0f /* 00001111 */
-#define SCM_I_DDD_PAT 0x2a /* 00101010 */
-#define SCM_I_DDA_PAT 0x2b /* 00101011 */
-#define SCM_I_DAD_PAT 0x2e /* 00101110 */
-#define SCM_I_DAA_PAT 0x2f /* 00101111 */
-#define SCM_I_ADD_PAT 0x3a /* 00111010 */
-#define SCM_I_ADA_PAT 0x3b /* 00111011 */
-#define SCM_I_AAD_PAT 0x3e /* 00111110 */
-#define SCM_I_AAA_PAT 0x3f /* 00111111 */
-#define SCM_I_DDDD_PAT 0xaa /* 10101010 */
-#define SCM_I_DDDA_PAT 0xab /* 10101011 */
-#define SCM_I_DDAD_PAT 0xae /* 10101110 */
-#define SCM_I_DDAA_PAT 0xaf /* 10101111 */
-#define SCM_I_DADD_PAT 0xba /* 10111010 */
-#define SCM_I_DADA_PAT 0xbb /* 10111011 */
-#define SCM_I_DAAD_PAT 0xbe /* 10111110 */
-#define SCM_I_DAAA_PAT 0xbf /* 10111111 */
-#define SCM_I_ADDD_PAT 0xea /* 11101010 */
-#define SCM_I_ADDA_PAT 0xeb /* 11101011 */
-#define SCM_I_ADAD_PAT 0xee /* 11101110 */
-#define SCM_I_ADAA_PAT 0xef /* 11101111 */
-#define SCM_I_AADD_PAT 0xfa /* 11111010 */
-#define SCM_I_AADA_PAT 0xfb /* 11111011 */
-#define SCM_I_AAAD_PAT 0xfe /* 11111110 */
-#define SCM_I_AAAA_PAT 0xff /* 11111111 */
-
-SCM_API SCM scm_i_chase_pairs (SCM x, scm_t_uint32 pattern);
-
-#define scm_cddr(x) scm_i_chase_pairs ((x), SCM_I_DD_PAT)
-#define scm_cdar(x) scm_i_chase_pairs ((x), SCM_I_DA_PAT)
-#define scm_cadr(x) scm_i_chase_pairs ((x), SCM_I_AD_PAT)
-#define scm_caar(x) scm_i_chase_pairs ((x), SCM_I_AA_PAT)
-#define scm_cdddr(x) scm_i_chase_pairs ((x), SCM_I_DDD_PAT)
-#define scm_cddar(x) scm_i_chase_pairs ((x), SCM_I_DDA_PAT)
-#define scm_cdadr(x) scm_i_chase_pairs ((x), SCM_I_DAD_PAT)
-#define scm_cdaar(x) scm_i_chase_pairs ((x), SCM_I_DAA_PAT)
-#define scm_caddr(x) scm_i_chase_pairs ((x), SCM_I_ADD_PAT)
-#define scm_cadar(x) scm_i_chase_pairs ((x), SCM_I_ADA_PAT)
-#define scm_caadr(x) scm_i_chase_pairs ((x), SCM_I_AAD_PAT)
-#define scm_caaar(x) scm_i_chase_pairs ((x), SCM_I_AAA_PAT)
-#define scm_cddddr(x) scm_i_chase_pairs ((x), SCM_I_DDDD_PAT)
-#define scm_cdddar(x) scm_i_chase_pairs ((x), SCM_I_DDDA_PAT)
-#define scm_cddadr(x) scm_i_chase_pairs ((x), SCM_I_DDAD_PAT)
-#define scm_cddaar(x) scm_i_chase_pairs ((x), SCM_I_DDAA_PAT)
-#define scm_cdaddr(x) scm_i_chase_pairs ((x), SCM_I_DADD_PAT)
-#define scm_cdadar(x) scm_i_chase_pairs ((x), SCM_I_DADA_PAT)
-#define scm_cdaadr(x) scm_i_chase_pairs ((x), SCM_I_DAAD_PAT)
-#define scm_cdaaar(x) scm_i_chase_pairs ((x), SCM_I_DAAA_PAT)
-#define scm_cadddr(x) scm_i_chase_pairs ((x), SCM_I_ADDD_PAT)
-#define scm_caddar(x) scm_i_chase_pairs ((x), SCM_I_ADDA_PAT)
-#define scm_cadadr(x) scm_i_chase_pairs ((x), SCM_I_ADAD_PAT)
-#define scm_cadaar(x) scm_i_chase_pairs ((x), SCM_I_ADAA_PAT)
-#define scm_caaddr(x) scm_i_chase_pairs ((x), SCM_I_AADD_PAT)
-#define scm_caadar(x) scm_i_chase_pairs ((x), SCM_I_AADA_PAT)
-#define scm_caaadr(x) scm_i_chase_pairs ((x), SCM_I_AAAD_PAT)
-#define scm_caaaar(x) scm_i_chase_pairs ((x), SCM_I_AAAA_PAT)
+SCM_API SCM scm_cddr (SCM x);
+SCM_API SCM scm_cdar (SCM x);
+SCM_API SCM scm_cadr (SCM x);
+SCM_API SCM scm_caar (SCM x);
+SCM_API SCM scm_cdddr (SCM x);
+SCM_API SCM scm_cddar (SCM x);
+SCM_API SCM scm_cdadr (SCM x);
+SCM_API SCM scm_cdaar (SCM x);
+SCM_API SCM scm_caddr (SCM x);
+SCM_API SCM scm_cadar (SCM x);
+SCM_API SCM scm_caadr (SCM x);
+SCM_API SCM scm_caaar (SCM x);
+SCM_API SCM scm_cddddr (SCM x);
+SCM_API SCM scm_cdddar (SCM x);
+SCM_API SCM scm_cddadr (SCM x);
+SCM_API SCM scm_cddaar (SCM x);
+SCM_API SCM scm_cdaddr (SCM x);
+SCM_API SCM scm_cdadar (SCM x);
+SCM_API SCM scm_cdaadr (SCM x);
+SCM_API SCM scm_cdaaar (SCM x);
+SCM_API SCM scm_cadddr (SCM x);
+SCM_API SCM scm_caddar (SCM x);
+SCM_API SCM scm_cadadr (SCM x);
+SCM_API SCM scm_cadaar (SCM x);
+SCM_API SCM scm_caaddr (SCM x);
+SCM_API SCM scm_caadar (SCM x);
+SCM_API SCM scm_caaadr (SCM x);
+SCM_API SCM scm_caaaar (SCM x);
SCM_INTERNAL void scm_init_pairs (void);
#include <unistr.h>
#include <striconveh.h>
+#include <assert.h>
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/eval.h"
#include "libguile/fports.h" /* direct access for seek and truncate */
-#include "libguile/objects.h"
#include "libguile/goops.h"
#include "libguile/smob.h"
#include "libguile/chars.h"
#include <string.h>
#endif
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
#ifdef HAVE_IO_H
#include <io.h>
#endif
gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
might be possibilities if we've got other systems without ftruncate. */
-#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
+#if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
#define ftruncate(fd, size) chsize (fd, size)
#undef HAVE_FTRUNCATE
#define HAVE_FTRUNCATE 1
* Indexes into this table are used when generating type
* tags for smobjects (if you know a tag you can get an index and conversely).
*/
-scm_t_ptob_descriptor *scm_ptobs;
-long scm_numptob;
+scm_t_ptob_descriptor *scm_ptobs = NULL;
+long scm_numptob = 0;
/* GC marker for a port with stream of SCM type. */
SCM
{
}
-static size_t
-scm_port_free0 (SCM port)
-{
- return 0;
-}
-
scm_t_bits
scm_make_port_type (char *name,
int (*fill_input) (SCM port),
if (SCM_I_MAX_PORT_TYPE_COUNT - 1 <= scm_numptob)
goto ptoberr;
SCM_CRITICAL_SECTION_START;
- SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
- (1 + scm_numptob)
- * sizeof (scm_t_ptob_descriptor)));
+ tmp = (char *) scm_gc_realloc ((char *) scm_ptobs,
+ scm_numptob * sizeof (scm_t_ptob_descriptor),
+ (1 + scm_numptob)
+ * sizeof (scm_t_ptob_descriptor),
+ "port-type");
if (tmp)
{
scm_ptobs = (scm_t_ptob_descriptor *) tmp;
scm_ptobs[scm_numptob].name = name;
scm_ptobs[scm_numptob].mark = 0;
- scm_ptobs[scm_numptob].free = scm_port_free0;
+ scm_ptobs[scm_numptob].free = NULL;
scm_ptobs[scm_numptob].print = scm_port_print;
scm_ptobs[scm_numptob].equalp = 0;
scm_ptobs[scm_numptob].close = 0;
scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-/* This function is not and should not be thread safe. */
+\f
+/* Port finalization. */
+
+
+static void finalize_port (GC_PTR, GC_PTR);
+
+/* Register a finalizer for PORT, if needed by its port type. */
+static SCM_C_INLINE_KEYWORD void
+register_finalizer_for_port (SCM port)
+{
+ long port_type;
+
+ port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
+ if (scm_ptobs[port_type].free)
+ {
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalization_data;
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
+ &prev_finalizer,
+ &prev_finalization_data);
+ }
+}
+
+/* Finalize the object (a port) pointed to by PTR. */
+static void
+finalize_port (GC_PTR ptr, GC_PTR data)
+{
+ long port_type;
+ SCM port = PTR2SCM (ptr);
+
+ if (!SCM_PORTP (port))
+ abort ();
+
+ if (SCM_OPENP (port))
+ {
+ if (SCM_REVEALED (port) > 0)
+ /* Keep "revealed" ports alive and re-register a finalizer. */
+ register_finalizer_for_port (port);
+ else
+ {
+ port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
+ if (port_type >= scm_numptob)
+ abort ();
+
+ if (scm_ptobs[port_type].free)
+ /* Yes, I really do mean `.free' rather than `.close'. `.close'
+ is for explicit `close-port' by user. */
+ scm_ptobs[port_type].free (port);
+
+ SCM_SETSTREAM (port, 0);
+ SCM_CLR_PORT_OPEN_FLAG (port);
+ scm_gc_ports_collected++;
+ }
+ }
+}
+
+
+
+\f
+
+/* This function is not and should not be thread safe. */
SCM
scm_new_port_table_entry (scm_t_bits tag)
#define FUNC_NAME "scm_new_port_table_entry"
if ((enc = scm_i_get_port_encoding (SCM_BOOL_F)) == NULL)
entry->encoding = NULL;
else
- entry->encoding = strdup (enc);
+ entry->encoding = scm_gc_strdup (enc, "port");
entry->ilseq_handler = scm_i_get_conversion_strategy (SCM_BOOL_F);
SCM_SET_CELL_TYPE (z, tag);
scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F);
+ /* For each new port, register a finalizer so that it port type's free
+ function can be invoked eventually. */
+ register_finalizer_for_port (z);
+
return z;
}
#undef FUNC_NAME
#define FUNC_NAME "scm_remove_port"
{
scm_t_port *p = SCM_PTAB_ENTRY (port);
- if (p->putback_buf)
- scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
- if (p->encoding)
- {
- free (p->encoding);
- p->encoding = NULL;
- }
- scm_gc_free (p, sizeof (scm_t_port), "port");
+
+ scm_port_non_buffer (p);
+
+ p->putback_buf = NULL;
+ p->putback_buf_size = 0;
SCM_SETPTAB_ENTRY (port, 0);
scm_hashq_remove_x (scm_i_port_weak_hash, port);
if (pt->encoding == NULL)
{
/* The encoding is Latin-1: bytes are characters. */
- codepoint = buf[0];
+ codepoint = (unsigned char) buf[0];
goto success;
}
requested number of bytes. (Note that a single scm_fill_input
call does not guarantee to fill the whole of the port's read
buffer.) */
- if (pt->read_buf_size <= 1)
+ if (pt->read_buf_size <= 1 && pt->encoding == NULL)
{
/* The port that we are reading from is unbuffered - i.e. does
not have its own persistent buffer - but we have a buffer,
We need to make sure that the port's normal (1 byte) buffer
is reinstated in case one of the scm_fill_input () calls
throws an exception; we use the scm_dynwind_* API to achieve
- that. */
+ that.
+
+ A consequence of this optimization is that the fill_input
+ functions can't unget characters. That'll push data to the
+ pushback buffer instead of this psb buffer. */
+#if SCM_DEBUG == 1
+ unsigned char *pback = pt->putback_buf;
+#endif
psb.pt = pt;
psb.buffer = buffer;
psb.size = size;
pt->read_buf_size -= (pt->read_end - pt->read_pos);
pt->read_pos = pt->read_buf = pt->read_end;
}
+#if SCM_DEBUG == 1
+ if (pback != pt->putback_buf
+ || pt->read_buf - (unsigned char *) buffer < 0)
+ scm_misc_error (FUNC_NAME,
+ "scm_c_read must not call a fill function that pushes "
+ "back characters onto an unbuffered port", SCM_EOL);
+#endif
n_read += pt->read_buf - (unsigned char *) buffer;
-
+
/* Reinstate the port's normal buffer. */
scm_dynwind_end ();
}
}
#undef FUNC_NAME
-void
+void
scm_flush (SCM port)
{
long i = SCM_PTOBNUM (port);
+ assert (i >= 0);
(scm_ptobs[i].flush) (port);
}
if (pt->putback_buf == NULL)
{
pt->putback_buf
- = (unsigned char *) scm_gc_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE,
- "putback buffer");
+ = (unsigned char *) scm_gc_malloc_pointerless
+ (SCM_INITIAL_PUTBACK_BUF_SIZE, "putback buffer");
pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
}
}
#undef FUNC_NAME
-/* The default port encoding for this locale. New ports will have this
- encoding. If it is a string, that is the encoding. If it #f, it
- is in the native (Latin-1) encoding. */
-SCM_GLOBAL_VARIABLE (scm_port_encoding_var, "%port-encoding");
+/* A fluid specifying the default encoding for newly created ports. If it is
+ a string, that is the encoding. If it is #f, it is in the "native"
+ (Latin-1) encoding. */
+SCM_VARIABLE (default_port_encoding_var, "%default-port-encoding");
+
static int scm_port_encoding_init = 0;
/* Return a C string representation of the current encoding. */
{
if (!scm_port_encoding_init)
return NULL;
- else if (!scm_is_fluid (SCM_VARIABLE_REF (scm_port_encoding_var)))
+ else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
return NULL;
else
{
- encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_port_encoding_var));
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
if (!scm_is_string (encoding))
return NULL;
else
}
}
-/* Returns ENC is if is a recognized encoding. If it isn't, it tries
+/* Returns ENC if it is a recognized encoding. If it isn't, it tries
to find an alias of ENC that is valid. Otherwise, it returns
NULL. */
static const char *
{
/* Set the default encoding for future ports. */
if (!scm_port_encoding_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_port_encoding_var)))
+ || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
scm_misc_error (NULL, "tried to set port encoding fluid before it is initialized",
SCM_EOL);
|| !strcmp (valid_enc, "ASCII")
|| !strcmp (valid_enc, "ANSI_X3.4-1968")
|| !strcmp (valid_enc, "ISO-8859-1"))
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), SCM_BOOL_F);
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
else
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var),
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
scm_from_locale_string (valid_enc));
}
else
{
/* Set the character encoding for this port. */
pt = SCM_PTAB_ENTRY (port);
- if (pt->encoding)
- free (pt->encoding);
if (valid_enc == NULL)
pt->encoding = NULL;
else
- pt->encoding = strdup (valid_enc);
+ pt->encoding = scm_gc_strdup (valid_enc, "port");
}
}
return scm_from_locale_string ("NONE");
}
#undef FUNC_NAME
-
+
SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0,
(SCM port, SCM enc),
"Sets the character encoding that will be used to interpret all\n"
"appropriate for the current locale if @code{setlocale} has \n"
"been called or ISO-8859-1 otherwise\n"
"and this procedure can be used to modify that encoding.\n")
-
#define FUNC_NAME s_scm_set_port_encoding_x
{
char *enc_str;
return 1;
}
-void
-scm_ports_prehistory ()
-{
- scm_numptob = 0;
- scm_ptobs = (scm_t_ptob_descriptor *) scm_malloc (sizeof (scm_t_ptob_descriptor));
-}
-
\f
/* Void ports. */
scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port,
write_void_port);
- cur_inport_fluid = scm_permanent_object (scm_make_fluid ());
- cur_outport_fluid = scm_permanent_object (scm_make_fluid ());
- cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
- cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_inport_fluid = scm_make_fluid ();
+ cur_outport_fluid = scm_make_fluid ();
+ cur_errport_fluid = scm_make_fluid ();
+ cur_loadport_fluid = scm_make_fluid ();
+
+ scm_i_port_weak_hash = scm_make_weak_key_hash_table (SCM_I_MAKINUM(31));
- scm_i_port_weak_hash = scm_permanent_object (scm_make_weak_key_hash_table (SCM_I_MAKINUM(31)));
#include "libguile/ports.x"
- SCM_VARIABLE_SET (scm_port_encoding_var, scm_make_fluid ());
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), SCM_BOOL_F);
+ /* Use Latin-1 as the default port encoding. */
+ SCM_VARIABLE_SET (default_port_encoding_var, scm_make_fluid ());
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
scm_port_encoding_init = 1;
-
+
SCM_VARIABLE_SET (scm_conversion_strategy, scm_make_fluid ());
scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy),
scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK));
SCM_API scm_t_ptob_descriptor *scm_ptobs;
SCM_API long scm_numptob;
-SCM_INTERNAL long scm_i_port_table_room;
\f
SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_print_port_mode (SCM exp, SCM port);
-SCM_API void scm_ports_prehistory (void);
SCM_API SCM scm_void_port (char * mode_str);
SCM_API SCM scm_sys_make_void_port (SCM mode);
SCM_INTERNAL void scm_init_ports (void);
#if SCM_ENABLE_DEPRECATED==1
-SCM_API scm_t_port * scm_add_to_port_table (SCM port);
+SCM_DEPRECATED scm_t_port * scm_add_to_port_table (SCM port);
#endif
#ifdef GUILE_DEBUG
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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
#undef FUNC_NAME
#endif /* HAVE_TCSETPGRP */
-static void
-free_string_pointers (void *data)
-{
- scm_i_free_string_pointers ((char **)data);
-}
-
SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
(SCM filename, SCM args),
"Executes the file named by @var{path} as a new process image.\n"
scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
- scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
- SCM_F_WIND_EXPLICITLY);
execv (exec_file,
#ifdef __MINGW32__
scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
- scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
- SCM_F_WIND_EXPLICITLY);
execvp (exec_file,
#ifdef __MINGW32__
scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
- scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
- SCM_F_WIND_EXPLICITLY);
-
exec_env = scm_i_allocate_string_pointers (env);
- scm_dynwind_unwind_handler (free_string_pointers, exec_env,
- SCM_F_WIND_EXPLICITLY);
execve (exec_file,
#ifdef __MINGW32__
return scm_makfromstrs (-1, environ);
else
{
- char **new_environ;
-
- new_environ = scm_i_allocate_string_pointers (env);
- /* Free the old environment, except when called for the first
- * time.
- */
- {
- static int first = 1;
- if (!first)
- scm_i_free_string_pointers (environ);
- first = 0;
- }
- environ = new_environ;
+ environ = scm_i_allocate_string_pointers (env);
return SCM_UNSPECIFIED;
}
}
}
#undef FUNC_NAME
#endif /* HAVE_SETLOCALE */
-SCM_DEFINE (scm_setbinary, "setbinary", 0, 0, 0,
- (void),
- "Sets the encoding for the current input, output, and error\n"
- "ports to ISO-8859-1. That character encoding allows\n"
- "ports to operate on binary data.\n"
- "\n"
- "It also sets the default encoding for newly created ports\n"
- "to ISO-8859-1.\n"
- "\n"
- "The previous default encoding for new ports is returned\n")
-#define FUNC_NAME s_scm_setbinary
-{
- const char *enc = scm_i_get_port_encoding (SCM_BOOL_F);
-
- /* Set the default encoding for new ports. */
- scm_i_set_port_encoding_x (SCM_BOOL_F, NULL);
- /* Set the encoding for the stdio ports. */
- scm_i_set_port_encoding_x (scm_current_input_port (), NULL);
- scm_i_set_port_encoding_x (scm_current_output_port (), NULL);
- scm_i_set_port_encoding_x (scm_current_error_port (), NULL);
-
- if (enc)
- return scm_from_locale_string (enc);
-
- return scm_from_locale_string ("ISO-8859-1");
-}
-#undef FUNC_NAME
-
#ifdef HAVE_MKNOD
SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0,
#ifndef SCM_POSIX_H
#define SCM_POSIX_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2006, 2008, 2009 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
SCM_API SCM scm_getpid (void);
SCM_API SCM scm_putenv (SCM str);
SCM_API SCM scm_setlocale (SCM category, SCM locale);
-SCM_API SCM scm_setbinary (void);
SCM_API SCM scm_mknod (SCM path, SCM type, SCM perms, SCM dev);
SCM_API SCM scm_nice (SCM incr);
SCM_API SCM scm_sync (void);
#include "libguile/programs.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
-#include "libguile/objects.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
static const char *iflagnames[] =
{
"#f",
+ "#nil", /* Elisp nil value. Should print from elisp as symbol `nil'. */
+ "#<XXX UNUSED LISP FALSE -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
+ "()",
"#t",
+ "#<XXX UNUSED BOOLEAN -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
+ "#<unspecified>",
"#<undefined>",
"#<eof>",
- "()",
- "#<unspecified>",
/* Unbound slot marker for GOOPS. For internal use in GOOPS only. */
"#<unbound>",
-
- /* Elisp nil value. This is its Scheme name; whenever it's printed in
- * Elisp, it should appear as the symbol `nil'. */
- "#nil"
};
SCM_SYMBOL (sym_reader, "reader");
{
switch (SCM_ITAG3 (exp))
{
- case scm_tc3_closure:
case scm_tc3_tc7_1:
case scm_tc3_tc7_2:
/* These tc3 tags should never occur in an immediate value. They are
/* Print the character if is graphic character. */
{
scm_t_wchar *wbuf;
- SCM wstr = scm_i_make_wide_string (1, &wbuf);
+ SCM wstr;
char *buf;
size_t len;
const char *enc;
enc = scm_i_get_port_encoding (port);
- wbuf[0] = i;
+ if (uc_combining_class (i) == UC_CCC_NR)
+ {
+ wstr = scm_i_make_wide_string (1, &wbuf);
+ wbuf[0] = i;
+ }
+ else
+ {
+ /* Character is a combining character: print it connected
+ to a dotted circle instead of connecting it to the
+ backslash in '#\' */
+ wstr = scm_i_make_wide_string (2, &wbuf);
+ wbuf[0] = SCM_CODEPOINT_DOTTED_CIRCLE;
+ wbuf[1] = i;
+ }
if (enc == NULL)
{
if (i <= 0xFF)
{
scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
}
- else if (SCM_ISYMP (exp))
- {
- scm_i_print_isym (exp, port);
- }
- else if (SCM_ILOCP (exp))
- {
- scm_i_print_iloc (exp, port);
- }
else
{
/* unknown immediate value */
circref:
print_circref (port, pstate, exp);
break;
- case scm_tcs_closures:
- if (scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
- || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
- exp, port, pstate)))
- {
- SCM formals = SCM_CLOSURE_FORMALS (exp);
- scm_puts ("#<procedure", port);
- scm_putc (' ', port);
- scm_iprin1 (scm_procedure_name (exp), port, pstate);
- scm_putc (' ', port);
- if (SCM_PRINT_SOURCE_P)
- {
- SCM env = SCM_ENV (exp);
- SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
- SCM src = scm_i_unmemocopy_body (SCM_CODE (exp), xenv);
- ENTER_NESTED_DATA (pstate, exp, circref);
- scm_iprin1 (src, port, pstate);
- EXIT_NESTED_DATA (pstate);
- }
- else
- scm_iprin1 (formals, port, pstate);
- scm_putc ('>', port);
- }
- break;
case scm_tc7_number:
switch SCM_TYP16 (exp) {
case scm_tc16_big:
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
+ case scm_tc7_hashtable:
+ scm_i_hashtable_print (exp, port, pstate);
+ break;
+ case scm_tc7_fluid:
+ scm_i_fluid_print (exp, port, pstate);
+ break;
+ case scm_tc7_dynamic_state:
+ scm_i_dynamic_state_print (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
scm_puts ("#w(", port);
goto common_vector_printer;
+ case scm_tc7_bytevector:
+ scm_i_print_bytevector (exp, port, pstate);
+ break;
case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_puts ("#(", port);
last = pstate->length - 1;
cutp = 1;
}
- for (i = 0; i < last; ++i)
+ if (SCM_I_WVECTP (exp))
{
- /* CHECK_INTS; */
- scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
- scm_putc (' ', port);
+ /* Elements of weak vectors may not be accessed via the
+ `SIMPLE_VECTOR_REF ()' macro. */
+ for (i = 0; i < last; ++i)
+ {
+ scm_iprin1 (scm_c_vector_ref (exp, i),
+ port, pstate);
+ scm_putc (' ', port);
+ }
+ }
+ else
+ {
+ for (i = 0; i < last; ++i)
+ {
+ scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
+ scm_putc (' ', port);
+ }
}
+
if (i == last)
{
/* CHECK_INTS; */
- scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
+ scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
}
if (cutp)
scm_puts (" ...", port);
}
EXIT_NESTED_DATA (pstate);
break;
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
{
SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp));
scm_puts (SCM_SUBR_GENERIC (exp)
scm_putc ('>', port);
break;
}
- case scm_tc7_pws:
- scm_puts ("#<procedure-with-setter", port);
- {
- SCM name = scm_procedure_name (exp);
- if (scm_is_true (name))
- {
- scm_putc (' ', port);
- scm_display (name, port);
- }
- }
- scm_putc ('>', port);
- break;
case scm_tc7_port:
{
register long i = SCM_PTOBNUM (exp);
EXIT_NESTED_DATA (pstate);
break;
default:
+ /* case scm_tcs_closures: */
punk:
scm_ipruk ("type", exp, port);
}
{
scm_puts ("#<unknown-", port);
scm_puts (hdr, port);
- if (scm_in_heap_p (ptr))
+ if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
{
scm_puts (" (0x", port);
scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
SCM_VALIDATE_CHAR (1, chr);
SCM_VALIDATE_OPORT_VALUE (2, port);
-
- scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
+
+ scm_i_charprint (SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
/* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */
scm_tc16_port_with_ps = scm_make_smob_type (0, 0);
- scm_set_smob_mark (scm_tc16_port_with_ps, scm_markcdr);
scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print);
#include "libguile/print.x"
-/*
- * private-gc.h - private declarations for garbage collection.
- *
- * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09 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
- */
-
-#ifndef PRIVATE_GC
-#define PRIVATE_GC
-
-#include "_scm.h"
-
-/* {heap tuning parameters}
- *
- * These are parameters for controlling memory allocation. The heap
- * is the area out of which scm_cons, and object headers are allocated.
- *
- * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
- * 64 bit machine. The units of the _SIZE parameters are bytes.
- * Cons pairs and object headers occupy one heap cell.
- *
- * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
- * is needed.
- */
-
-
-/*
- * Heap size 45000 and 40% min yield gives quick startup and no extra
- * heap allocation. Having higher values on min yield may lead to
- * large heaps, especially if code behaviour is varying its
- * maximum consumption between different freelists.
- */
-
-/*
- These values used to be global C variables. However, they're also
- available through the environment, and having a double interface is
- confusing. Now they're #defines --hwn.
- */
-
-#define SCM_DEFAULT_INIT_HEAP_SIZE_1 256*1024
-#define SCM_DEFAULT_MIN_YIELD_1 40
-#define SCM_DEFAULT_INIT_HEAP_SIZE_2 32*1024
-
-/*
- How many cells to collect during one sweep call. This is the pool
- size of each thread.
- */
-#define DEFAULT_SWEEP_AMOUNT 512
-
-/* The following value may seem large, but note that if we get to GC at
- * all, this means that we have a numerically intensive application
- */
-#define SCM_DEFAULT_MIN_YIELD_2 40
-
-#define SCM_DEFAULT_MAX_SEGMENT_SIZE (20*1024*1024L)
-
-#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_SIZEOF_CARD)
-#define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell))
-
-#define SCM_DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)
-
-
-#define SCM_GC_CARD_BVEC_SIZE_IN_LONGS \
- ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LONG_BITS - 1) / SCM_C_BVEC_LONG_BITS)
-#define SCM_GC_IN_CARD_HEADERP(x) \
- (scm_t_cell *) (x) < SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS
-
-int scm_getenv_int (const char *var, int def);
-
-
-typedef enum { return_on_error, abort_on_error } policy_on_error;
-
-/* gc-freelist */
-
-/*
- FREELIST:
-
- A struct holding GC statistics on a particular type of cells.
-
- Counts in cells are mainly for heap statistics, and for
- double-cells, they are still measured in single-cell units.
-*/
-typedef struct scm_t_cell_type_statistics {
- /*
- heap segment where the last cell was allocated
- */
- int heap_segment_idx;
-
- /* defines min_yield as fraction of total heap size
- */
- float min_yield_fraction;
-
- /* number of cells per object on this list */
- int span;
-
- /* number of collected cells during last GC. */
- unsigned long collected;
-
- unsigned long swept;
-
- /*
- Total number of cells in heap segments belonging to this list.
- */
- unsigned long heap_total_cells;
-} scm_t_cell_type_statistics;
-
-
-/* Sweep statistics. */
-typedef struct scm_sweep_statistics
-{
- /* Number of cells "swept", i.e., visited during the sweep operation. */
- unsigned swept;
-
- /* Number of cells collected during the sweep operation. This number must
- always be lower than or equal to SWEPT. */
- unsigned collected;
-} scm_t_sweep_statistics;
-
-SCM_INTERNAL scm_t_sweep_statistics scm_i_gc_sweep_stats;
-
-\f
-extern scm_t_cell_type_statistics scm_i_master_freelist;
-extern scm_t_cell_type_statistics scm_i_master_freelist2;
-
-SCM_INTERNAL
-void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist,
- scm_t_sweep_statistics sweep_stats,
- scm_t_sweep_statistics sweep_stats_1);
-SCM_INTERNAL
-void scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist);
-SCM_INTERNAL float
-scm_i_gc_heap_size_delta (scm_t_cell_type_statistics * freelist);
-
-
-#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
-#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
-
-/* CELL_P checks a random word whether it has the right form for a
- pointer to a cell. Use scm_i_find_heap_segment_containing_object
- to find out whether it actually points to a real cell.
-
- The right form for a cell pointer is this: the low three bits must
- be scm_tc3_cons, and when the scm_tc3_cons tag is stripped, the
- resulting pointer must be correctly aligned.
- scm_i_initialize_heap_segment_data guarantees that the test below
- works.
-*/
-#define CELL_P(x) ((SCM_UNPACK(x) & (sizeof(scm_t_cell)-1)) == scm_tc3_cons)
-
-/*
- gc-mark
- */
-
-/* Non-zero while in the mark phase. */
-SCM_INTERNAL int scm_i_marking;
-
-SCM_INTERNAL void scm_mark_all (void);
-
-/*
-gc-segment:
-*/
-
-/*
-
- Cells are stored in a heap-segment: it is a contiguous chunk of
- memory, that associated with one freelist.
-*/
-typedef struct scm_t_heap_segment
-{
- /*
- {lower, upper} bounds of the segment
-
- The upper bound is also the start of the mark space.
- */
- scm_t_cell *bounds[2];
-
- /*
- If we ever decide to give it back, we could do it with this ptr.
-
- Note that giving back memory is not very useful; as long we don't
- touch a chunk of memory, the virtual memory system will keep it
- swapped out. We could simply forget about a block.
-
- (not that we do that, but anyway.)
- */
- void *malloced;
-
- scm_t_cell *next_free_card;
-
- /* address of the head-of-freelist pointer for this segment's cells.
- All segments usually point to the same one, scm_i_freelist. */
- scm_t_cell_type_statistics *freelist;
-
- /* number of cells per object in this segment */
- int span;
-
- /*
- Is this the first time that the cells are accessed?
- */
- int first_time;
-} scm_t_heap_segment;
-
-/*
- A table of segment records is kept that records the upper and
- lower extents of the segment; this is used during the conservative
- phase of gc to identify probably gc roots (because they point
- into valid segments at reasonable offsets).
-*/
-extern scm_t_heap_segment ** scm_i_heap_segment_table;
-extern size_t scm_i_heap_segment_table_size;
-
-
-SCM_INTERNAL int scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,
- scm_t_heap_segment*);
-SCM_INTERNAL int scm_i_sweep_card (scm_t_cell *card, SCM *free_list,
- scm_t_heap_segment *);
-SCM_INTERNAL int scm_i_card_marked_count (scm_t_cell *card, int span);
-SCM_INTERNAL void scm_i_card_statistics (scm_t_cell *p, SCM hashtab,
- scm_t_heap_segment *seg);
-SCM_INTERNAL char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */
-
-SCM_INTERNAL int scm_i_initialize_heap_segment_data (scm_t_heap_segment *seg,
- size_t requested);
-
-SCM_INTERNAL int scm_i_segment_cells_per_card (scm_t_heap_segment *seg);
-SCM_INTERNAL int scm_i_segment_card_number (scm_t_heap_segment *seg,
- scm_t_cell *card);
-SCM_INTERNAL int scm_i_segment_card_count (scm_t_heap_segment *seg);
-SCM_INTERNAL int scm_i_segment_cell_count (scm_t_heap_segment *seg);
-SCM_INTERNAL int scm_i_heap_segment_marked_count (scm_t_heap_segment *seg);
-
-SCM_INTERNAL void scm_i_clear_segment_mark_space (scm_t_heap_segment *seg);
-SCM_INTERNAL scm_t_heap_segment *
-scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*);
-SCM_INTERNAL SCM scm_i_sweep_for_freelist (scm_t_cell_type_statistics *seg);
-SCM_INTERNAL SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg,
- scm_t_sweep_statistics *sweep_stats,
- int threshold);
-SCM_INTERNAL void scm_i_sweep_segment (scm_t_heap_segment *seg,
- scm_t_sweep_statistics *sweep_stats);
-
-SCM_INTERNAL void scm_i_heap_segment_statistics (scm_t_heap_segment *seg,
- SCM tab);
-
-
-SCM_INTERNAL int scm_i_insert_segment (scm_t_heap_segment *seg);
-SCM_INTERNAL int scm_i_find_heap_segment_containing_object (SCM obj);
-SCM_INTERNAL int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
- size_t length,
- policy_on_error);
-SCM_INTERNAL int scm_i_marked_count (void);
-SCM_INTERNAL void scm_i_clear_mark_space (void);
-SCM_INTERNAL void scm_i_sweep_segments (void);
-SCM_INTERNAL SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics *fl,
- scm_t_sweep_statistics *sweep_stats);
-SCM_INTERNAL void scm_i_reset_segments (void);
-SCM_INTERNAL void scm_i_sweep_all_segments (char const *reason,
- scm_t_sweep_statistics *sweep_stats);
-SCM_INTERNAL SCM scm_i_all_segments_statistics (SCM hashtab);
-SCM_INTERNAL unsigned long *scm_i_segment_table_info(int *size);
-
-SCM_INTERNAL long int scm_i_deprecated_memory_return;
-SCM_INTERNAL long int scm_i_find_heap_calls;
-SCM_INTERNAL long int scm_i_last_marked_cell_count;
-
-/*
- global init funcs.
- */
-void scm_gc_init_malloc (void);
-void scm_gc_init_freelist (void);
-void scm_gc_init_segments (void);
-void scm_gc_init_mark (void);
-
-
-#endif
+/*
+ * private-gc.h - private declarations for garbage collection.
+ *
+ * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09 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
+ */
+
+#ifndef SCM_PRIVATE_GC
+#define SCM_PRIVATE_GC
+
+#include "_scm.h"
+
+/* {heap tuning parameters}
+ *
+ * These are parameters for controlling memory allocation. The heap
+ * is the area out of which scm_cons, and object headers are allocated.
+ *
+ * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
+ * 64 bit machine. The units of the _SIZE parameters are bytes.
+ * Cons pairs and object headers occupy one heap cell.
+ */
+
+
+#define SCM_DEFAULT_INIT_HEAP_SIZE_2 32*1024
+
+#define SCM_DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)
+
+
+SCM_INTERNAL int scm_getenv_int (const char *var, int def);
+
+
+typedef enum { return_on_error, abort_on_error } policy_on_error;
+
+
+#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
+#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
+
+/* CELL_P checks a random word whether it has the right form for a
+ pointer to a cell. Use scm_i_find_heap_segment_containing_object
+ to find out whether it actually points to a real cell.
+
+ The right form for a cell pointer is this: the low three bits must
+ be scm_tc3_cons, and when the scm_tc3_cons tag is stripped, the
+ resulting pointer must be correctly aligned.
+ scm_i_initialize_heap_segment_data guarantees that the test below
+ works.
+*/
+#define CELL_P(x) ((SCM_UNPACK(x) & (sizeof(scm_t_cell)-1)) == scm_tc3_cons)
+
+SCM_INTERNAL char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */
+
+#endif
* We put this in a private header, since layout of data structures
* is an implementation detail that we want to hide.
*
- * Copyright (C) 2007 Free Software Foundation, Inc.
+ * Copyright (C) 2007, 2009 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
*/
SCM_API scm_t_option scm_eval_opts[];
-SCM_API long scm_eval_stack;
-
SCM_API scm_t_option scm_evaluator_trap_table[];
SCM_API SCM scm_eval_options_interface (SCM setting);
#include "libguile/eval.h"
#include "libguile/procs.h"
#include "libguile/gsubr.h"
-#include "libguile/objects.h"
#include "libguile/smob.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
-SCM
-scm_i_procedure_arity (SCM proc)
+static SCM props;
+static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+int
+scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{
- int a = 0, o = 0, r = 0;
if (SCM_IMP (proc))
- return SCM_BOOL_F;
+ return 0;
loop:
switch (SCM_TYP7 (proc))
{
- case scm_tc7_subr_1o:
- o = 1;
- case scm_tc7_subr_0:
- break;
- case scm_tc7_subr_2o:
- o = 1;
- case scm_tc7_subr_1:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- a += 1;
- break;
- case scm_tc7_subr_2:
- a += 2;
- break;
- case scm_tc7_subr_3:
- a += 3;
- break;
- case scm_tc7_asubr:
- case scm_tc7_rpsubr:
- case scm_tc7_lsubr:
- r = 1;
- break;
case scm_tc7_program:
- a += SCM_PROGRAM_DATA (proc)->nargs;
- r = SCM_PROGRAM_DATA (proc)->nrest;
- a -= r;
- break;
- case scm_tc7_lsubr_2:
- a += 2;
- r = 1;
- break;
+ return scm_i_program_arity (proc, req, opt, rest);
case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc))
{
int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
- a += SCM_GSUBR_REQ (type);
- o = SCM_GSUBR_OPT (type);
- r = SCM_GSUBR_REST (type);
- break;
+ *req = SCM_GSUBR_REQ (type);
+ *opt = SCM_GSUBR_OPT (type);
+ *rest = SCM_GSUBR_REST (type);
+ return 1;
}
else
- {
- return SCM_BOOL_F;
- }
+ return 0;
case scm_tc7_gsubr:
{
unsigned int type = SCM_GSUBR_TYPE (proc);
- a = SCM_GSUBR_REQ (type);
- o = SCM_GSUBR_OPT (type);
- r = SCM_GSUBR_REST (type);
- break;
+ *req = SCM_GSUBR_REQ (type);
+ *opt = SCM_GSUBR_OPT (type);
+ *rest = SCM_GSUBR_REST (type);
+ return 1;
}
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- goto loop;
- case scm_tcs_closures:
- proc = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (proc))
- break;
- while (scm_is_pair (proc))
- {
- ++a;
- proc = SCM_CDR (proc);
- }
- if (!scm_is_null (proc))
- r = 1;
- break;
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- r = 1;
- break;
- }
- else if (!SCM_I_OPERATORP (proc))
- return SCM_BOOL_F;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
- a -= 1;
+ if (!SCM_STRUCT_APPLICABLE_P (proc))
+ return 0;
+ proc = SCM_STRUCT_PROCEDURE (proc);
goto loop;
default:
- return SCM_BOOL_F;
+ return 0;
}
- return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
}
-/* XXX - instead of using a stand-in value for everything except
- closures, we should find other ways to store the procedure
- properties for those other kinds of procedures. For example, subrs
- have their own property slot, which is unused at present.
-*/
-
-static SCM
-scm_stand_in_scm_proc(SCM proc)
-{
- SCM handle, answer;
- handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
- if (scm_is_false (handle))
- {
- answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
- scm_hashq_set_x (scm_stand_in_procs, proc, answer);
- }
- else
- answer = SCM_CDR (handle);
- return answer;
-}
+/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
+ other means; for example subrs have their own property slot, which is unused
+ at present. */
SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
(SCM proc),
"Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
+ SCM ret;
+ int req, opt, rest;
+
SCM_VALIDATE_PROC (1, proc);
- return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
- SCM_PROCPROPS (SCM_CLOSUREP (proc)
- ? proc
- : scm_stand_in_scm_proc (proc)));
+
+ scm_i_pthread_mutex_lock (&props_lock);
+ ret = scm_hashq_ref (props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
+ scm_i_procedure_arity (proc, &req, &opt, &rest);
+
+ return scm_acons (scm_sym_arity,
+ scm_list_3 (scm_from_int (req),
+ scm_from_int (opt),
+ scm_from_bool (rest)),
+ ret);
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
- (SCM proc, SCM new_val),
- "Set @var{obj}'s property list to @var{alist}.")
+ (SCM proc, SCM alist),
+ "Set @var{proc}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_procedure_properties_x
{
- if (!SCM_CLOSUREP (proc))
- proc = scm_stand_in_scm_proc(proc);
- SCM_VALIDATE_CLOSURE (1, proc);
- SCM_SETPROCPROPS (proc, new_val);
+ SCM_VALIDATE_PROC (1, proc);
+
+ scm_i_pthread_mutex_lock (&props_lock);
+ scm_hashq_set_x (props, proc, alist);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
- (SCM p, SCM k),
- "Return the property of @var{obj} with name @var{key}.")
+ (SCM proc, SCM key),
+ "Return the property of @var{proc} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
- SCM assoc;
- if (scm_is_eq (k, scm_sym_arity))
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_eq (key, scm_sym_arity))
+ /* avoid a cons in this case */
+ {
+ int req, opt, rest;
+ scm_i_procedure_arity (proc, &req, &opt, &rest);
+ return scm_list_3 (scm_from_int (req),
+ scm_from_int (opt),
+ scm_from_bool (rest));
+ }
+ else
{
- SCM arity;
- SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
- p, SCM_ARG1, FUNC_NAME);
- return arity;
+ SCM ret;
+
+ scm_i_pthread_mutex_lock (&props_lock);
+ ret = scm_hashq_ref (props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
+ return scm_assq_ref (ret, key);
}
- SCM_VALIDATE_PROC (1, p);
- assoc = scm_sloppy_assq (k,
- SCM_PROCPROPS (SCM_CLOSUREP (p)
- ? p
- : scm_stand_in_scm_proc (p)));
- return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
- (SCM p, SCM k, SCM v),
- "In @var{obj}'s property list, set the property named @var{key} to\n"
- "@var{value}.")
+ (SCM proc, SCM key, SCM val),
+ "In @var{proc}'s property list, set the property named @var{key} to\n"
+ "@var{val}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
- SCM assoc;
- if (!SCM_CLOSUREP (p))
- p = scm_stand_in_scm_proc(p);
- SCM_VALIDATE_CLOSURE (1, p);
- if (scm_is_eq (k, scm_sym_arity))
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_eq (key, scm_sym_arity))
SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
- assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
- if (SCM_NIMP (assoc))
- SCM_SETCDR (assoc, v);
- else
- SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
+
+ scm_i_pthread_mutex_lock (&props_lock);
+ scm_hashq_set_x (props, proc,
+ scm_assq_set_x (scm_hashq_ref (props, proc,
+ SCM_EOL),
+ key, val));
+ scm_i_pthread_mutex_unlock (&props_lock);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void
scm_init_procprop ()
{
+ props = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/procprop.x"
}
#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009 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
\f
-SCM_INTERNAL SCM scm_i_procedure_arity (SCM proc);
+SCM_INTERNAL int scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest);
SCM_API SCM scm_procedure_properties (SCM proc);
-SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM new_val);
-SCM_API SCM scm_procedure_property (SCM p, SCM k);
-SCM_API SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v);
+SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
+SCM_API SCM scm_procedure_property (SCM proc, SCM key);
+SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
#include "libguile/_scm.h"
-#include "libguile/objects.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/smob.h"
return subr;
}
-/* This function isn't currently used since subrs are never freed. */
-/* *fixme* Need mutex here. */
-void
-scm_free_subr_entry (SCM subr)
-{
- scm_gc_free (SCM_SUBR_META_INFO (subr), 2 * sizeof (SCM),
- "subr meta-info");
-}
-
SCM
scm_c_make_subr_with_generic (const char *name,
long type, SCM (*fcn) (), SCM *gf)
switch (SCM_TYP7 (obj))
{
case scm_tcs_struct:
- if (!SCM_I_OPERATORP (obj))
+ if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
+ || SCM_STRUCT_APPLICABLE_P (obj)))
break;
- case scm_tcs_closures:
- case scm_tcs_subrs:
- case scm_tc7_pws:
+ case scm_tc7_gsubr:
case scm_tc7_program:
return SCM_BOOL_T;
case scm_tc7_smob:
}
#undef FUNC_NAME
-SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a closure.")
-#define FUNC_NAME s_scm_closure_p
-{
- return scm_from_bool (SCM_CLOSUREP (obj));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a thunk.")
#define FUNC_NAME s_scm_thunk_p
{
- if (SCM_NIMP (obj))
- {
- again:
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_closures:
- return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj)));
- case scm_tc7_subr_0:
- case scm_tc7_subr_1o:
- case scm_tc7_lsubr:
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- return SCM_BOOL_T;
- case scm_tc7_gsubr:
- return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
- case scm_tc7_program:
- return scm_from_bool (SCM_PROGRAM_DATA (obj)->nargs == 0
- || (SCM_PROGRAM_DATA (obj)->nargs == 1
- && SCM_PROGRAM_DATA (obj)->nrest));
- case scm_tc7_pws:
- obj = SCM_PROCEDURE (obj);
- goto again;
- default:
- if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0)
- return SCM_BOOL_T;
- /* otherwise fall through */
- }
- }
- return SCM_BOOL_F;
+ int req, opt, rest;
+ return scm_from_bool (scm_i_procedure_arity (obj, &req, &opt, &rest)
+ && req == 0);
}
#undef FUNC_NAME
if (SCM_NIMP (obj))
switch (SCM_TYP7 (obj))
{
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
return 1;
default:
;
"documentation for that procedure.")
#define FUNC_NAME s_scm_procedure_documentation
{
- SCM code;
- SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
- proc, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
if (SCM_PROGRAM_P (proc))
return scm_assq_ref (scm_program_properties (proc), sym_documentation);
- switch (SCM_TYP7 (proc))
- {
- case scm_tcs_closures:
- code = SCM_CLOSURE_BODY (proc);
- if (scm_is_null (SCM_CDR (code)))
- return SCM_BOOL_F;
- code = SCM_CAR (code);
- if (scm_is_string (code))
- return code;
- else
- return SCM_BOOL_F;
- default:
- return SCM_BOOL_F;
- }
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
/* Procedure-with-setter
*/
+static SCM pws_vtable;
+
+
SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a procedure with an\n"
"associated setter procedure.")
#define FUNC_NAME s_scm_procedure_with_setter_p
{
- return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
+ return scm_from_bool (SCM_STRUCTP (obj) && SCM_STRUCT_SETTER_P (obj));
}
#undef FUNC_NAME
SCM name, ret;
SCM_VALIDATE_PROC (1, procedure);
SCM_VALIDATE_PROC (2, setter);
- ret = scm_double_cell (scm_tc7_pws,
- SCM_UNPACK (procedure),
- SCM_UNPACK (setter), 0);
+ ret = scm_make_struct (pws_vtable, SCM_INUM0,
+ scm_list_2 (procedure, setter));
+
/* don't use procedure_name, because don't care enough to do a reverse
lookup */
switch (SCM_TYP7 (procedure)) {
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
name = SCM_SUBR_NAME (procedure);
break;
default:
SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
(SCM proc),
- "Return the procedure of @var{proc}, which must be either a\n"
- "procedure with setter, or an operator struct.")
+ "Return the procedure of @var{proc}, which must be an\n"
+ "applicable struct.")
#define FUNC_NAME s_scm_procedure
{
SCM_VALIDATE_NIM (1, proc);
- if (SCM_PROCEDURE_WITH_SETTER_P (proc))
- return SCM_PROCEDURE (proc);
- else if (SCM_STRUCTP (proc))
- {
- SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME);
- return proc;
- }
- SCM_WRONG_TYPE_ARG (1, proc);
- return SCM_BOOL_F; /* not reached */
+ SCM_ASSERT (SCM_STRUCT_APPLICABLE_P (proc), proc, SCM_ARG1, FUNC_NAME);
+ return SCM_STRUCT_PROCEDURE (proc);
}
#undef FUNC_NAME
-SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
-
-SCM
-scm_setter (SCM proc)
+SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
+ (SCM proc),
+ "Return the setter of @var{proc}, which must be an\n"
+ "applicable struct with a setter.")
+#define FUNC_NAME s_scm_setter
{
- SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
- if (SCM_PROCEDURE_WITH_SETTER_P (proc))
- return SCM_SETTER (proc);
- else if (SCM_STRUCTP (proc))
- {
- SCM setter;
- SCM_GASSERT1 (SCM_I_OPERATORP (proc),
- g_setter, proc, SCM_ARG1, s_setter);
- setter = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_SETTER (proc)
- : SCM_OPERATOR_SETTER (proc));
- if (SCM_NIMP (setter))
- return setter;
- /* fall through */
- }
- SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
+ SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
+ if (SCM_STRUCT_SETTER_P (proc))
+ return SCM_STRUCT_SETTER (proc);
+ if (SCM_PUREGENERICP (proc))
+ /* FIXME: might not be an accessor */
+ return SCM_GENERIC_SETTER (proc);
+ SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
return SCM_BOOL_F; /* not reached */
}
+#undef FUNC_NAME
\f
void
scm_init_procs ()
{
+ pws_vtable =
+ scm_c_make_struct (scm_applicable_struct_with_setter_vtable_vtable,
+ 0,
+ 1,
+ SCM_UNPACK (scm_from_locale_symbol ("pwpw")));
+
#include "libguile/procs.x"
}
#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0])
#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
-#define SCM_SET_SUBRF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))
-#define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x))
#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x))
#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits) g))
-/* Closures
- */
-
-#define SCM_CLOSUREP(x) (!SCM_IMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
-#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
-#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
-#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x))
-#define SCM_CLOSURE_BODY(x) SCM_CDR (SCM_CODE (x))
-#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
-#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
-#define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \
- + scm_tc3_closure))
-#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x)
-#define SCM_SETENV(x, e) SCM_SET_CELL_OBJECT_1 ((x), (e))
-#define SCM_TOP_LEVEL(ENV) (scm_is_null (ENV) || (scm_is_true (scm_procedure_p (SCM_CAR (ENV)))))
-
-/* Procedure-with-setter
-
- Four representations for procedure-with-setters were
- considered before selecting this one:
-
- 1. A closure where the CODE and ENV slots are used to represent
- the getter and a new SETTER slot is used for the setter. The
- original getter is stored as a `getter' procedure property. For
- closure getters, the CODE and ENV slots contains a copy of the
- getter's CODE and ENV slots. For subr getters, the CODE contains
- a call to the subr.
-
- 2. A compiled closure with a call to the getter in the cclo
- procedure. The getter and setter are stored in slots 1 and 2.
-
- 3. An entity (i.e. a struct with an associated procedure) with a
- call to the getter in the entity procedure and the setter stored
- in slot 0. The original getter is stored in slot 1.
-
- 4. A new primitive procedure type supported in the evaluator. The
- getter and setter are stored in a GETTER and SETTER slot. A call
- to this procedure type results in a retrieval of the getter and a
- jump back to the correct eval dispatcher.
-
- Representation 4 was selected because of efficiency and
- simplicity.
-
- Rep 1 has the advantage that there is zero penalty for closure
- getters, but primitive getters will get considerable overhead
- because the procedure-with-getter will be a closure which calls
- the getter.
-
- Rep 3 has the advantage that a GOOPS accessor can be a subclass of
- <procedure-with-setter>, but together with rep 2 it suffers from a
- three level dispatch for non-GOOPS getters:
-
- cclo/struct --> dispatch proc --> getter
-
- This is because the dispatch procedure must take an extra initial
- argument (cclo for rep 2, struct for rep 3).
-
- Rep 4 has the single disadvantage that it uses up one tc7 type
- code, but the plan for uniform vectors will very likely free tc7
- codes, so this is probably no big problem. Also note that the
- GETTER and SETTER slots can live directly on the heap, using the
- new four-word cells. */
-
-#define SCM_PROCEDURE_WITH_SETTER_P(obj) (!SCM_IMP(obj) && (SCM_TYP7 (obj) == scm_tc7_pws))
-#define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj)
-#define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj)
+/* Return the most suitable subr type for a subr with REQ required arguments,
+ OPT optional arguments, and REST (0 or 1) arguments. This has to be in
+ sync with `create_gsubr ()'. */
+#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest) \
+ (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
\f
-SCM_API void scm_free_subr_entry (SCM subr);
SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());
SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
SCM (*fcn)(), SCM *gf);
SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type,
SCM (*fcn)(), SCM *gf);
SCM_API SCM scm_procedure_p (SCM obj);
-SCM_API SCM scm_closure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
SCM_API int scm_subr_p (SCM obj);
SCM_API SCM scm_procedure_documentation (SCM proc);
#include "instructions.h"
#include "modules.h"
#include "programs.h"
-#include "procprop.h" // scm_sym_name
-#include "srcprop.h" // scm_sym_filename
+#include "procprop.h" /* scm_sym_name */
+#include "srcprop.h" /* scm_sym_filename */
#include "vm.h"
\f
{
static int print_error = 0;
- if (SCM_FALSEP (write_program) && scm_module_system_booted_p)
+ if (scm_is_false (write_program) && scm_module_system_booted_p)
write_program = scm_module_local_variable
(scm_c_resolve_module ("system vm program"),
scm_from_locale_symbol ("write-program"));
- if (SCM_FALSEP (write_program) || print_error)
+ if (scm_is_false (write_program) || print_error)
{
scm_puts ("#<program ", port);
scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
"")
#define FUNC_NAME s_scm_program_p
{
- return SCM_BOOL (SCM_PROGRAM_P (obj));
+ return scm_from_bool (SCM_PROGRAM_P (obj));
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_arity
-{
- struct scm_objcode *p;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- p = SCM_PROGRAM_DATA (program);
- return scm_list_3 (SCM_I_MAKINUM (p->nargs),
- SCM_I_MAKINUM (p->nrest),
- SCM_I_MAKINUM (p->nlocs));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
(SCM program),
"")
}
#undef FUNC_NAME
+SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_arities
+{
+ SCM meta;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ meta = scm_program_meta (program);
+ if (scm_is_false (meta))
+ return SCM_BOOL_F;
+
+ return scm_caddr (scm_call_0 (meta));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
(SCM program),
"")
if (scm_is_false (meta))
return SCM_EOL;
- return scm_cddr (scm_call_0 (meta));
+ return scm_cdddr (scm_call_0 (meta));
}
#undef FUNC_NAME
}
#undef FUNC_NAME
+/* This one is a shim to pre-case-lambda internal interfaces. Avoid it if you
+ can -- use program-arguments or the like. */
+static SCM sym_arglist;
+int
+scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+{
+ SCM arities, x;
+
+ arities = scm_program_arities (program);
+ if (!scm_is_pair (arities))
+ return 0;
+ /* take the last arglist, it will be least specific */
+ while (scm_is_pair (scm_cdr (arities)))
+ arities = scm_cdr (arities);
+ x = scm_cddar (arities);
+ if (scm_is_pair (x))
+ {
+ *req = scm_to_int (scm_car (x));
+ x = scm_cdr (x);
+ if (scm_is_pair (x))
+ {
+ *opt = scm_to_int (scm_car (x));
+ x = scm_cdr (x);
+ if (scm_is_pair (x))
+ *rest = scm_is_true (scm_car (x));
+ else
+ *rest = 0;
+ }
+ else
+ *opt = *rest = 0;
+ }
+ else
+ *req = *opt = *rest = 0;
+
+ return 1;
+}
\f
+
void
scm_bootstrap_programs (void)
{
+ /* arglist can't be snarfed, because snarfage is only loaded when (system vm
+ program) is loaded. perhaps static-alloc will fix this. */
+ sym_arglist = scm_from_locale_symbol ("arglist");
scm_c_register_extension ("libguile", "scm_init_programs",
(scm_t_extension_init_func)scm_init_programs, NULL);
}
* Programs
*/
-#define SCM_F_PROGRAM_IS_BOOT (1<<16)
+#define SCM_F_PROGRAM_IS_BOOT 0x100
#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
SCM_API SCM scm_program_p (SCM obj);
SCM_API SCM scm_program_base (SCM program);
-SCM_API SCM scm_program_arity (SCM program);
SCM_API SCM scm_program_meta (SCM program);
SCM_API SCM scm_program_bindings (SCM program);
SCM_API SCM scm_program_sources (SCM program);
SCM_API SCM scm_program_source (SCM program, SCM ip);
+SCM_API SCM scm_program_arities (SCM program);
SCM_API SCM scm_program_properties (SCM program);
SCM_API SCM scm_program_name (SCM program);
SCM_API SCM scm_program_objects (SCM program);
SCM_API SCM scm_c_program_source (SCM program, size_t ip);
+SCM_INTERNAL int scm_i_program_arity (SCM program, int *req, int *opt, int *rest);
SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_programs (void);
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+ * 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
+ */
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
+#include "libguile/__scm.h"
+
+#include "libguile/_scm.h"
+#include "libguile/alist.h"
+#include "libguile/async.h"
+#include "libguile/continuations.h"
+#include "libguile/debug.h"
+#include "libguile/deprecation.h"
+#include "libguile/dynwind.h"
+#include "libguile/eq.h"
+#include "libguile/eval.h"
+#include "libguile/feature.h"
+#include "libguile/fluids.h"
+#include "libguile/goops.h"
+#include "libguile/hash.h"
+#include "libguile/hashtab.h"
+#include "libguile/lang.h"
+#include "libguile/list.h"
+#include "libguile/macros.h"
+#include "libguile/memoize.h"
+#include "libguile/modules.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/procprop.h"
+#include "libguile/programs.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/strings.h"
+#include "libguile/threads.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/promises.h"
+
+
+\f
+
+
+scm_t_bits scm_tc16_promise;
+
+SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0,
+ (SCM thunk),
+ "Create a new promise object.\n\n"
+ "@code{make-promise} is a procedural form of @code{delay}.\n"
+ "These two expressions are equivalent:\n"
+ "@lisp\n"
+ "(delay @var{exp})\n"
+ "(make-promise (lambda () @var{exp}))\n"
+ "@end lisp\n")
+#define FUNC_NAME s_scm_make_promise
+{
+ SCM_VALIDATE_THUNK (1, thunk);
+ SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
+ SCM_UNPACK (thunk),
+ scm_make_recursive_mutex ());
+}
+#undef FUNC_NAME
+
+static int
+promise_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_puts ("#<promise ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_putc ('>', port);
+ return !0;
+}
+
+SCM_DEFINE (scm_force, "force", 1, 0, 0,
+ (SCM promise),
+ "If the promise @var{x} has not been computed yet, compute and\n"
+ "return @var{x}, otherwise just return the previously computed\n"
+ "value.")
+#define FUNC_NAME s_scm_force
+{
+ SCM_VALIDATE_SMOB (1, promise, promise);
+ scm_lock_mutex (SCM_PROMISE_MUTEX (promise));
+ if (!SCM_PROMISE_COMPUTED_P (promise))
+ {
+ SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
+ if (!SCM_PROMISE_COMPUTED_P (promise))
+ {
+ SCM_SET_PROMISE_DATA (promise, ans);
+ SCM_SET_PROMISE_COMPUTED (promise);
+ }
+ }
+ scm_unlock_mutex (SCM_PROMISE_MUTEX (promise));
+ return SCM_PROMISE_DATA (promise);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
+ "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
+#define FUNC_NAME s_scm_promise_p
+{
+ return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
+}
+#undef FUNC_NAME
+
+void
+scm_init_promises ()
+{
+ scm_tc16_promise = scm_make_smob_type ("promise", 0);
+ scm_set_smob_print (scm_tc16_promise, promise_print);
+
+#include "libguile/promises.x"
+
+ scm_add_feature ("delay");
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
+
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_PROMISES_H
+#define SCM_PROMISES_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009
+ * 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+/* {Promises}
+ */
+
+#define SCM_F_PROMISE_COMPUTED (1L << 0)
+#define SCM_PROMISE_COMPUTED_P(promise) \
+ (SCM_F_PROMISE_COMPUTED & SCM_SMOB_FLAGS (promise))
+#define SCM_SET_PROMISE_COMPUTED(promise) \
+ SCM_SET_SMOB_FLAGS ((promise), SCM_F_PROMISE_COMPUTED)
+#define SCM_PROMISE_MUTEX SCM_SMOB_OBJECT_2
+#define SCM_PROMISE_DATA SCM_SMOB_OBJECT
+#define SCM_SET_PROMISE_DATA SCM_SET_SMOB_OBJECT
+
+
+SCM_API scm_t_bits scm_tc16_promise;
+
+\f
+
+SCM_API SCM scm_make_promise (SCM thunk);
+SCM_API SCM scm_force (SCM x);
+SCM_API SCM scm_promise_p (SCM x);
+
+SCM_INTERNAL void scm_init_promises (void);
+
+
+#endif /* SCM_PROMISES_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009 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
/* {Properties}
*/
+static SCM properties_whash;
+
SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0,
(SCM not_found_proc),
"Create a @dfn{property token} that can be used with\n"
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_get_handle (scm_properties_whash, obj);
+ h = scm_hashq_get_handle (properties_whash, obj);
if (scm_is_true (h))
{
SCM assoc = scm_assq (prop, SCM_CDR (h));
{
SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
if (scm_is_false (h))
- h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
+ h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
return val;
}
{
SCM h, assoc;
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
+ h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
assoc = scm_assq (prop, SCM_CDR (h));
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, val);
{
SCM h;
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_get_handle (scm_properties_whash, obj);
+ h = scm_hashq_get_handle (properties_whash, obj);
if (scm_is_true (h))
SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
return SCM_UNSPECIFIED;
void
scm_init_properties ()
{
- scm_properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/properties.x"
}
#include <pthread.h>
#include <sched.h>
+/* `libgc' intercepts pthread calls by defining wrapping macros. */
+#include "libguile/bdw-gc.h"
+
/* Threads
*/
#define scm_i_pthread_t pthread_t
+++ /dev/null
-/* Copyright (C) 1991, 2000, 2001, 2004, 2005, 2006 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/scmconfig.h"
-
-#include <sys/types.h>
-#include <errno.h>
-
-/* Don't include stdlib.h for non-GNU C libraries because some of them
- contain conflicting prototypes for getopt.
- This needs to come after some library #include
- to get __GNU_LIBRARY__ defined. */
-#ifdef __GNU_LIBRARY__
-#include <stdlib.h>
-#else
-char *malloc ();
-#endif /* GNU C library. */
-
-#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
-#include <string.h>
-#else
-#include <strings.h>
-#ifndef strchr
-#define strchr index
-#endif
-#ifndef memcpy
-#define memcpy(d, s, n) bcopy((s), (d), (n))
-#endif
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#if HAVE_CRT_EXTERNS_H
-#include <crt_externs.h> /* for Darwin _NSGetEnviron */
-#endif
-
-#ifndef NULL
-#define NULL 0
-#endif
-
-extern char **environ;
-
-/* On Apple Darwin in a shared library there's no "environ" to access
- directly, instead the address of that variable must be obtained with
- _NSGetEnviron(). */
-#if HAVE__NSGETENVIRON && defined (PIC)
-#define environ (*_NSGetEnviron())
-#endif
-
-/* Put STRING, which is of the form "NAME=VALUE", in the environment. */
-int
-putenv (const char *string)
-{
- char *name_end = strchr (string, '=');
- register size_t size;
- register char **ep;
-
- if (name_end == NULL)
- {
- /* Remove the variable from the environment. */
- size = strlen (string);
- for (ep = environ; *ep != NULL; ++ep)
- if (!strncmp (*ep, string, size) && (*ep)[size] == '=')
- {
- while (ep[1] != NULL)
- {
- ep[0] = ep[1];
- ++ep;
- }
- *ep = NULL;
- return 0;
- }
- }
-
- size = 0;
- for (ep = environ; *ep != NULL; ++ep)
- if (!strncmp (*ep, string, name_end - string) &&
- (*ep)[name_end - string] == '=')
- break;
- else
- ++size;
-
- if (*ep == NULL)
- {
- static char **last_environ = NULL;
- char **new_environ = (char **) scm_malloc ((size + 2) * sizeof (char *));
- memcpy ((char *) new_environ, (char *) environ, size * sizeof (char *));
- new_environ[size] = (char *) string;
- new_environ[size + 1] = NULL;
- if (last_environ != NULL)
- free ((char *) last_environ);
- last_environ = new_environ;
- environ = new_environ;
- }
- else
- *ep = (char *) string;
-
- return 0;
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
static void
NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
- scm_t_trampoline_2 cmp, SCM less)
+ SCM less)
{
/* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct {
SCM_TICK;
- if (scm_is_true ((*cmp) (less, ELT(mid), ELT(lo))))
+ if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
SWAP (ELT(mid), ELT(lo));
- if (scm_is_true ((*cmp) (less, ELT(hi), ELT(mid))))
+ if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid))))
SWAP (ELT(mid), ELT(hi));
else
goto jump_over;
- if (scm_is_true ((*cmp) (less, ELT(mid), ELT(lo))))
+ if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
SWAP (ELT(mid), ELT(lo));
jump_over:;
that this algorithm runs much faster than others. */
do
{
- while (scm_is_true ((*cmp) (less, ELT(left), pivot)))
+ while (scm_is_true (scm_call_2 (less, ELT(left), pivot)))
{
left += 1;
/* The comparison predicate may be buggy */
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
}
- while (scm_is_true ((*cmp) (less, pivot, ELT(right))))
+ while (scm_is_true (scm_call_2 (less, pivot, ELT(right))))
{
right -= 1;
/* The comparison predicate may be buggy */
and the operation speeds up insertion sort's inner loop. */
for (run = tmp + 1; run <= thresh; run += 1)
- if (scm_is_true ((*cmp) (less, ELT(run), ELT(tmp))))
+ if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
tmp = run;
if (tmp != 0)
SCM_TICK;
tmp = run - 1;
- while (scm_is_true ((*cmp) (less, ELT(run), ELT(tmp))))
+ while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
{
/* The comparison predicate may be buggy */
if (tmp == 0)
return port;
}
-static SCM
-bip_mark (SCM port)
-{
- /* Mark the underlying bytevector. */
- return (SCM_PACK (SCM_STREAM (port)));
-}
-
static int
bip_fill_input (SCM port)
{
scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input,
NULL);
- scm_set_port_mark (bytevector_input_port_type, bip_mark);
scm_set_port_seek (bytevector_input_port_type, bip_seek);
}
#define SCM_CBP_CLOSE_PROC(_port) \
SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
-static SCM
-cbp_mark (SCM port)
-{
- /* Mark the underlying method and object vector. */
- if (SCM_OPENP (port))
- return SCM_PACK (SCM_STREAM (port));
- else
- return SCM_BOOL_F;
-}
-
static scm_t_off
cbp_seek (SCM port, scm_t_off offset, int whence)
#define FUNC_NAME "cbp_seek"
scm_make_port_type ("r6rs-custom-binary-input-port",
cbip_fill_input, NULL);
- scm_set_port_mark (custom_binary_input_port_type, cbp_mark);
scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
scm_set_port_close (custom_binary_input_port_type, cbp_close);
}
SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
c_len = 4096;
- c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
c_total = 0;
do
SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
c_len = c_count = 4096;
- c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
c_total = c_read = 0;
do
new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
new_size, SCM_GC_BOP);
else
- new_buf = scm_gc_malloc (new_size, SCM_GC_BOP);
+ new_buf = scm_gc_malloc_pointerless (new_size, SCM_GC_BOP);
buf->buffer = new_buf;
buf->total_len = new_size;
return (scm_values (scm_list_2 (port, bop_proc)));
}
-static size_t
-bop_free (SCM port)
-{
- /* The port itself is necessarily freed _after_ the bop proc, since the bop
- proc holds a reference to it. Thus we can safely free the internal
- buffer when the bop becomes unreferenced. */
- scm_t_bop_buffer *buf;
-
- buf = SCM_BOP_BUFFER (port);
- if (buf->buffer)
- scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP);
-
- scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP);
-
- return 0;
-}
-
/* Write SIZE octets from DATA to PORT. */
static void
bop_write (SCM port, const void *data, size_t size)
return bv;
}
-SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark,
- bop_proc)
-{
- /* Mark the port associated with BOP_PROC. */
- return (SCM_PACK (SCM_SMOB_DATA (bop_proc)));
-}
-
-
SCM_DEFINE (scm_open_bytevector_output_port,
"open-bytevector-output-port", 0, 1, 0,
(SCM transcoder),
NULL, bop_write);
scm_set_port_seek (bytevector_output_port_type, bop_seek);
- scm_set_port_free (bytevector_output_port_type, bop_free);
}
\f
scm_make_port_type ("r6rs-custom-binary-output-port",
NULL, cbop_write);
- scm_set_port_mark (custom_binary_output_port_type, cbp_mark);
scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
scm_set_port_close (custom_binary_output_port_type, cbp_close);
}
scm_t_i_rstate *
scm_i_copy_rstate (scm_t_i_rstate *state)
{
- scm_t_rstate *new_state = scm_malloc (scm_the_rng.rstate_size);
+ scm_t_rstate *new_state;
+
+ new_state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
+ "random-state");
return memcpy (new_state, state, scm_the_rng.rstate_size);
}
scm_t_rstate *
scm_c_make_rstate (const char *seed, int n)
{
- scm_t_rstate *state = scm_malloc (scm_the_rng.rstate_size);
+ scm_t_rstate *state;
+
+ state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
+ "random-state");
state->reserved0 = 0;
scm_the_rng.init_rstate (state, seed, n);
return state;
SCM_RETURN_NEWSMOB (scm_tc16_rstate, state);
}
-static size_t
-rstate_free (SCM rstate)
-{
- free (SCM_RSTATE (rstate));
- return 0;
-}
/*
* Scheme level interface.
scm_the_rng = rng;
scm_tc16_rstate = scm_make_smob_type ("random-state", 0);
- scm_set_smob_free (scm_tc16_rstate, rstate_free);
for (m = 1; m <= 0x100; m <<= 1)
for (i = m >> 1; i < m; ++i)
#include "libguile/hashtab.h"
#include "libguile/hash.h"
#include "libguile/ports.h"
+#include "libguile/fports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
|| ((_chr) == 'd') || ((_chr) == 'l'))
/* Read an SCSH block comment. */
-static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
-static SCM scm_read_commented_expression (int chr, SCM port);
+static inline SCM scm_read_scsh_block_comment (scm_t_wchar, SCM);
+static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM);
+static SCM scm_read_commented_expression (scm_t_wchar, SCM);
+static SCM scm_get_hash_procedure (int);
/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
zero if the whole token fits in BUF, non-zero otherwise. */
case ';':
scm_read_commented_expression (c, port);
break;
+ case '|':
+ if (scm_is_false (scm_get_hash_procedure (c)))
+ {
+ scm_read_r6rs_block_comment (c, port);
+ break;
+ }
+ /* fall through */
default:
scm_ungetc (c, port);
return '#';
static SCM scm_read_expression (SCM port);
static SCM scm_read_sharp (int chr, SCM port);
-static SCM scm_get_hash_procedure (int c);
static SCM recsexpr (SCM obj, long line, int column, SCM filename);
return SCM_MAKE_CHAR (scm_i_string_ref (charname, 0));
cp = scm_i_string_ref (charname, 0);
+ if (cp == SCM_CODEPOINT_DOTTED_CIRCLE && charname_len == 2)
+ return SCM_MAKE_CHAR (scm_i_string_ref (charname, 1));
+
if (cp >= '0' && cp < '8')
{
/* Dirk:FIXME:: This type of character syntax is not R5RS
* compliant. Further, it should be verified that the constant
- * does only consist of octal digits. Finally, it should be
- * checked whether the resulting fixnum is in the range of
- * characters. */
+ * does only consist of octal digits. */
SCM p = scm_string_to_number (charname, scm_from_uint (8));
if (SCM_I_INUMP (p))
- return SCM_MAKE_CHAR (SCM_I_INUM (p));
+ {
+ scm_t_wchar c = SCM_I_INUM (p);
+ if (SCM_IS_UNICODE_CHAR (c))
+ return SCM_MAKE_CHAR (c);
+ else
+ scm_i_input_error (FUNC_NAME, port,
+ "out-of-range octal character escape: ~a",
+ scm_list_1 (charname));
+ }
}
/* The names of characters should never have non-Latin1
return SCM_UNSPECIFIED;
}
+static SCM
+scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port)
+{
+ /* Unlike SCSH-style block comments, SRFI-30/R6RS block comments may be
+ nested. So care must be taken. */
+ int nesting_level = 1;
+ int opening_seen = 0, closing_seen = 0;
+
+ while (nesting_level > 0)
+ {
+ int c = scm_getc (port);
+
+ if (c == EOF)
+ scm_i_input_error (__FUNCTION__, port,
+ "unterminated `#| ... |#' comment", SCM_EOL);
+
+ if (opening_seen)
+ {
+ if (c == '|')
+ nesting_level++;
+ opening_seen = 0;
+ }
+ else if (closing_seen)
+ {
+ if (c == '#')
+ nesting_level--;
+ closing_seen = 0;
+ }
+ else if (c == '|')
+ closing_seen = 1;
+ else if (c == '#')
+ opening_seen = 1;
+ else
+ opening_seen = closing_seen = 0;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
static SCM
scm_read_commented_expression (scm_t_wchar chr, SCM port)
{
if (len >= scm_i_string_length (buf) - 2)
{
+ SCM addy;
+
scm_i_string_stop_writing ();
- SCM addy = scm_i_make_string (1024, NULL);
+ addy = scm_i_make_string (1024, NULL);
buf = scm_string_append (scm_list_2 (buf, addy));
len = 0;
buf = scm_i_string_start_writing (buf);
default:
result = scm_read_sharp_extension (chr, port);
if (scm_is_eq (result, SCM_UNSPECIFIED))
- scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
- scm_list_1 (SCM_MAKE_CHAR (chr)));
+ {
+ /* To remain compatible with 1.8 and earlier, the following
+ characters have lower precedence than `read-hash-extend'
+ characters. */
+ switch (chr)
+ {
+ case '|':
+ return scm_read_r6rs_block_comment (chr, port);
+ default:
+ scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (chr)));
+ }
+ }
else
return result;
}
#define SCM_ENCODING_SEARCH_SIZE (500)
-/* Search the first few hundred characters of a file for
- an emacs-like coding declaration. */
+/* Search the first few hundred characters of a file for an Emacs-like coding
+ declaration. Returns either NULL or a string whose storage has been
+ allocated with `scm_gc_malloc ()'. */
char *
-scm_scan_for_encoding (SCM port)
+scm_i_scan_for_encoding (SCM port)
{
char header[SCM_ENCODING_SEARCH_SIZE+1];
size_t bytes_read;
int i;
int in_comment;
- bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+ if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
+ /* PORT is a non-seekable file port (e.g., as created by Bash when using
+ "guile <(echo '(display "hello")')") so bail out. */
+ return NULL;
+
+ bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+
scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
if (bytes_read > 3
/* grab the next token */
i = 0;
while (pos + i - header <= SCM_ENCODING_SEARCH_SIZE
- && (isalnum(pos[i]) || pos[i] == '_' || pos[i] == '-' || pos[i] == '.'))
+ && pos + i - header < bytes_read
+ && (isalnum((int) pos[i]) || pos[i] == '_' || pos[i] == '-'
+ || pos[i] == '.'))
i++;
if (i == 0)
return NULL;
- encoding = scm_malloc (i+1);
- memcpy (encoding, pos, i);
- encoding[i] ='\0';
+ encoding = scm_gc_strndup (pos, i, "encoding");
for (i = 0; i < strlen (encoding); i++)
encoding[i] = toupper ((int) encoding[i]);
i ++;
}
if (!in_comment)
- {
- /* This wasn't in a comment */
- free (encoding);
- return NULL;
- }
+ /* This wasn't in a comment */
+ return NULL;
+
if (utf8_bom && strcmp(encoding, "UTF-8"))
scm_misc_error (NULL,
"the port input declares the encoding ~s but is encoded as UTF-8",
scm_list_1 (scm_from_locale_string (encoding)));
-
+
return encoding;
}
SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
(SCM port),
- "Scans the port for an EMACS-like character coding declaration\n"
+ "Scans the port for an Emacs-like character coding declaration\n"
"near the top of the contents of a port with random-acessible contents.\n"
"The coding declaration is of the form\n"
"@code{coding: XXXXX} and must appear in a scheme comment.\n"
{
char *enc;
SCM s_enc;
-
- enc = scm_scan_for_encoding (port);
+
+ enc = scm_i_scan_for_encoding (port);
if (enc == NULL)
return SCM_BOOL_F;
else
{
s_enc = scm_from_locale_string (enc);
- free (enc);
return s_enc;
}
-
+
return SCM_BOOL_F;
}
#undef FUNC_NAME
#ifndef SCM_READ_H
#define SCM_READ_H
-/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000, 2006, 2008, 2009 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
SCM_API SCM scm_read (SCM port);
SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);
-SCM_INTERNAL char *scm_scan_for_encoding (SCM port);
+SCM_INTERNAL char *scm_i_scan_for_encoding (SCM port);
SCM_API SCM scm_file_encoding (SCM port);
SCM_INTERNAL void scm_i_input_error (const char *func, SCM port,
flag = SCM_CDR (flag);
}
- rx = scm_gc_malloc (sizeof(regex_t), "regex");
+ rx = scm_gc_malloc_pointerless (sizeof (regex_t), "regex");
c_pat = scm_to_locale_string (pat);
status = regcomp (rx, c_pat,
/* Make sure they're not passing REG_NOSUB;
-/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008, 2009 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
#include "libguile/root.h"
\f
-SCM scm_sys_protects[SCM_NUM_PROTECTS];
-
-\f
-
/* {call-with-dynamic-root}
*
* Suspending the current thread to evaluate a thunk on the
#ifndef SCM_ROOT_H
#define SCM_ROOT_H
-/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 2009 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
\f
-#define scm_flo0 scm_sys_protects[0]
-#define scm_listofnull scm_sys_protects[1]
-#define scm_nullvect scm_sys_protects[2]
-#define scm_nullstr scm_sys_protects[3]
-#define scm_keyword_obarray scm_sys_protects[4]
-#define scm_stand_in_procs scm_sys_protects[5]
-#define scm_object_whash scm_sys_protects[6]
-#define scm_permobjs scm_sys_protects[7]
-#define scm_asyncs scm_sys_protects[8]
-#define scm_protects scm_sys_protects[9]
-#define scm_properties_whash scm_sys_protects[10]
-#define scm_gc_registered_roots scm_sys_protects[11]
-#define scm_source_whash scm_sys_protects[12]
-#define SCM_NUM_PROTECTS 13
-
-SCM_API SCM scm_sys_protects[];
-
-\f
-
SCM_API SCM scm_internal_cwdr (scm_t_catch_body body,
void *body_data,
scm_t_catch_handler handler,
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009 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
#endif
}
-typedef struct {
- ssize_t res;
- int fd;
- char *buf;
- size_t n;
-} read_without_guile_data;
-
-static void *
-do_read_without_guile (void *raw_data)
-{
- read_without_guile_data *data = (read_without_guile_data *)raw_data;
- data->res = read (data->fd, data->buf, data->n);
- return NULL;
-}
-
-static ssize_t
-read_without_guile (int fd, char *buf, size_t n)
-{
- read_without_guile_data data;
- data.fd = fd;
- data.buf = buf;
- data.n = n;
- scm_without_guile (do_read_without_guile, &data);
- return data.res;
-}
-
static SCM
signal_delivery_thread (void *data)
{
while (1)
{
- n = read_without_guile (signal_pipe[0], &sigbyte, 1);
+ n = read (signal_pipe[0], &sigbyte, 1);
sig = sigbyte;
if (n == 1 && sig >= 0 && sig < NSIG)
{
install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
}
else
- SCM_OUT_OF_RANGE (2, handler);
+ {
+ SCM_CRITICAL_SECTION_END;
+ SCM_OUT_OF_RANGE (2, handler);
+ }
}
else if (scm_is_false (handler))
{
signal_handlers =
SCM_VARIABLE_LOC (scm_c_define ("signal-handlers",
scm_c_make_vector (NSIG, SCM_BOOL_F)));
- signal_handler_asyncs =
- scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
- signal_handler_threads =
- scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
+ signal_handler_asyncs = scm_c_make_vector (NSIG, SCM_BOOL_F);
+ signal_handler_threads = scm_c_make_vector (NSIG, SCM_BOOL_F);
for (i = 0; i < NSIG; i++)
{
-/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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
#include <errno.h>
#include <ctype.h>
+#include <version-etc.h>
+
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/feature.h"
if (message)
fprintf (fp, "%s\n", message);
- fprintf (fp,
- "Usage: %s OPTION ...\n"
+ fprintf (fp,
+ "Usage: %s [OPTION]... [FILE]...\n"
"Evaluate Scheme code, interactively or from a script.\n"
"\n"
" [-s] FILE load Scheme source code from FILE, and exit\n"
" -c EXPR evalute Scheme expression EXPR, and exit\n"
- " -- stop scanning arguments; run interactively\n"
+ " -- stop scanning arguments; run interactively\n\n"
"The above switches stop argument processing, and pass all\n"
"remaining arguments as the value of (command-line).\n"
"If FILE begins with `-' the -s switch is mandatory.\n"
" which is a list of numbers like \"2,13,14\"\n"
" -h, --help display this help and exit\n"
" -v, --version display version information and exit\n"
- " \\ read arguments from following script lines\n"
- "\n"
- "Please report bugs to bug-guile@gnu.org\n",
+ " \\ read arguments from following script lines\n",
scm_usage_name);
+ emit_bug_reporting_address ();
+
if (fatal)
exit (fatal);
}
|| ! strcmp (argv[i], "--version"))
{
/* Print version number. */
- printf ("Guile %s\n"
- "Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation\n"
- "Guile may be distributed under the terms of the GNU General Public Licence;\n"
- "certain other uses are permitted as well. For details, see the file\n"
- "`COPYING', which is included in the Guile distribution.\n"
- "There is no warranty, to the extent permitted by law.\n",
- scm_to_locale_string (scm_version ()));
+ version_etc (stdout, scm_usage_name, PACKAGE_NAME, PACKAGE_VERSION,
+ /* XXX: Use gettext for the string below. */
+ "the Guile developers", NULL);
exit (0);
}
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004 Free Software
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009 Free Software
* Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#ifdef HAVE_SYSTEM
#ifdef HAVE_WAITPID
-static void
-free_string_pointers (void *data)
-{
- scm_i_free_string_pointers ((char **)data);
-}
SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
(SCM args),
int pid;
char **execargv;
- scm_dynwind_begin (0);
-
/* allocate before fork */
execargv = scm_i_allocate_string_pointers (args);
- scm_dynwind_unwind_handler (free_string_pointers, execargv,
- SCM_F_WIND_EXPLICITLY);
/* make sure the child can't kill us (as per normal system call) */
sig_ign = scm_from_long ((unsigned long) SIG_IGN);
execvp (execargv[0], execargv);
SCM_SYSERROR;
/* not reached. */
- scm_dynwind_end ();
return SCM_BOOL_F;
}
else
scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
- scm_dynwind_end ();
return scm_from_int (status);
}
}
#include "libguile/_scm.h"
#include "libguile/async.h"
-#include "libguile/objects.h"
#include "libguile/goops.h"
#include "libguile/ports.h"
#include "libguile/smob.h"
+#include "libguile/bdw-gc.h"
+#include <gc/gc_mark.h>
+
+
\f
/* scm_smobs scm_numsmob
long scm_numsmob;
scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
-/* Lower 16 bit of data must be zero.
-*/
-void
-scm_i_set_smob_flags (SCM x, scm_t_bits data)
-{
- SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
-}
-
void
scm_assert_smob_type (scm_t_bits tag, SCM val)
{
return SCM_CELL_OBJECT_1 (ptr);
}
+\f
/* {Free}
*/
return 0;
}
-size_t
-scm_smob_free (SCM obj)
-{
- long n = SCM_SMOBNUM (obj);
- if (scm_smobs[n].size > 0)
- scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
- scm_smobs[n].size, SCM_SMOBNAME (n));
- return 0;
-}
-
+\f
/* {Print}
*/
scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
scm_smobs[new_smob].name = name;
- if (size != 0)
- {
- scm_smobs[new_smob].size = size;
- scm_smobs[new_smob].free = scm_smob_free;
- }
+ scm_smobs[new_smob].size = size;
/* Make a class object if Goops is present. */
if (SCM_UNPACK (scm_smob_class[0]) != 0)
SCM
scm_make_smob (scm_t_bits tc)
{
- long n = SCM_TC2SMOBNUM (tc);
+ scm_t_bits n = SCM_TC2SMOBNUM (tc);
size_t size = scm_smobs[n].size;
scm_t_bits data = (size > 0
? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
: 0);
- return scm_cell (tc, data);
+
+ SCM_RETURN_NEWSMOB (tc, data);
}
+
\f
-/* {Initialization for the type of free cells}
- */
+/* Marking SMOBs using user-supplied mark procedures. */
+
+
+/* The GC kind used for SMOB types that provide a custom mark procedure. */
+static int smob_gc_kind;
+
+
+/* The generic SMOB mark procedure that gets called for SMOBs allocated with
+ `scm_i_new_smob_with_mark_proc ()'. */
+static struct GC_ms_entry *
+smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit, GC_word env)
+{
+ register SCM cell;
+ register scm_t_bits tc, smobnum;
+
+ cell = PTR2SCM (addr);
+
+ if (SCM_TYP7 (cell) != scm_tc7_smob)
+ /* It is likely that the GC passed us a pointer to a free-list element
+ which we must ignore (see warning in `gc/gc_mark.h'). */
+ return mark_stack_ptr;
+
+ tc = SCM_CELL_WORD_0 (cell);
+ smobnum = SCM_TC2SMOBNUM (tc);
+
+ if (smobnum >= scm_numsmob)
+ /* The first word looks corrupt. */
+ abort ();
+
+ mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
+ mark_stack_ptr,
+ mark_stack_limit, NULL);
+ mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
+ mark_stack_ptr,
+ mark_stack_limit, NULL);
+ mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
+ mark_stack_ptr,
+ mark_stack_limit, NULL);
+
+ if (scm_smobs[smobnum].mark)
+ {
+ SCM obj;
-static int
-free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- char buf[100];
- sprintf (buf, "#<freed cell %p; GC missed a reference>",
- (void *) SCM_UNPACK (exp));
- scm_puts (buf, port);
-
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_debug_cell_accesses_p)
- abort();
+ SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
+ SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
+
+ /* Invoke the SMOB's mark procedure, which will in turn invoke
+ `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */
+ obj = scm_smobs[smobnum].mark (cell);
+
+ mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
+
+ if (SCM_NIMP (obj))
+ /* Mark the returned object. */
+ mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
+ mark_stack_ptr,
+ mark_stack_limit, NULL);
+
+ SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
+ SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
+ }
+
+ return mark_stack_ptr;
+
+}
+
+/* Mark object O. We assume that this function is only called during the
+ mark phase, i.e., from within `smob_mark ()' or one of its
+ descendents. */
+void
+scm_gc_mark (SCM o)
+{
+#define CURRENT_MARK_PTR \
+ ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
+#define CURRENT_MARK_LIMIT \
+ ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
+
+ if (SCM_NIMP (o))
+ {
+ /* At this point, the `current_mark_*' fields of the current thread
+ must be defined (they are set in `smob_mark ()'). */
+ register struct GC_ms_entry *mark_stack_ptr;
+
+ if (!CURRENT_MARK_PTR)
+ /* The function was not called from a mark procedure. */
+ abort ();
+
+ mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
+ CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
+ NULL);
+ SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
+ }
+#undef CURRENT_MARK_PTR
+#undef CURRENT_MARK_LIMIT
+}
+
+/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
+ provide a custom mark procedure and it will be honored. */
+SCM
+scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1,
+ scm_t_bits data2, scm_t_bits data3)
+{
+ /* Return a double cell. */
+ SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell),
+ smob_gc_kind));
+
+ SCM_SET_CELL_WORD_3 (cell, data3);
+ SCM_SET_CELL_WORD_2 (cell, data2);
+ SCM_SET_CELL_WORD_1 (cell, data1);
+ SCM_SET_CELL_WORD_0 (cell, tc);
+
+ return cell;
+}
+
+\f
+/* Finalize SMOB by calling its SMOB type's free function, if any. */
+void
+scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
+{
+ SCM smob;
+ size_t (* free_smob) (SCM);
+
+ smob = PTR2SCM (ptr);
+#if 0
+ printf ("finalizing SMOB %p (smobnum: %u)\n",
+ ptr, SCM_SMOBNUM (smob));
#endif
-
- return 1;
+ free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
+ if (free_smob)
+ free_smob (smob);
}
+\f
void
scm_smob_prehistory ()
{
long i;
- scm_t_bits tc;
+
+ smob_gc_kind = GC_new_kind (GC_new_free_list (),
+ GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
+ 0,
+ /* Clear new objects. As of version 7.1, libgc
+ doesn't seem to support passing 0 here. */
+ 1);
scm_numsmob = 0;
for (i = 0; i < MAX_SMOB_COUNT; ++i)
scm_smobs[i].apply_3 = 0;
scm_smobs[i].gsubr_type = 0;
}
-
- /* WARNING: This scm_make_smob_type call must be done first. */
- tc = scm_make_smob_type ("free", 0);
- scm_set_smob_print (tc, free_print);
}
/*
#include "libguile/__scm.h"
#include "libguile/print.h"
+#include "libguile/bdw-gc.h"
+
+
\f
/* This is the internal representation of a smob type */
int gsubr_type; /* Used in procprop.c */
} scm_smob_descriptor;
-\f
-
-#define SCM_NEWSMOB(z, tc, data) \
-do { \
- z = scm_cell ((tc), (scm_t_bits) (data)); \
-} while (0)
-#define SCM_RETURN_NEWSMOB(tc, data) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \
- return __SCM_smob_answer; \
+\f
+SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc,
+ scm_t_bits, scm_t_bits, scm_t_bits);
+
+
+
+#define SCM_NEWSMOB(z, tc, data) \
+do \
+ { \
+ register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \
+ z = (scm_smobs[_smobnum].mark \
+ ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data), \
+ 0, 0) \
+ : scm_cell (tc, (scm_t_bits)(data))); \
+ if (scm_smobs[_smobnum].free) \
+ { \
+ GC_finalization_proc _prev_finalizer; \
+ GC_PTR _prev_finalizer_data; \
+ \
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \
+ NULL, \
+ &_prev_finalizer, \
+ &_prev_finalizer_data); \
+ } \
+ } \
+while (0)
+
+#define SCM_RETURN_NEWSMOB(tc, data) \
+ do { SCM __SCM_smob_answer; \
+ SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \
+ return __SCM_smob_answer; \
} while (0)
-#define SCM_NEWSMOB2(z, tc, data1, data2) \
-do { \
- z = scm_double_cell ((tc), (scm_t_bits)(data1), (scm_t_bits)(data2), 0); \
-} while (0)
+#define SCM_NEWSMOB2(z, tc, data1, data2) \
+ SCM_NEWSMOB3 (z, tc, data1, data2, 0)
-#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \
- return __SCM_smob_answer; \
+#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \
+ do { SCM __SCM_smob_answer; \
+ SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \
+ return __SCM_smob_answer; \
} while (0)
-#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \
-do { \
- z = scm_double_cell ((tc), (scm_t_bits)(data1), \
- (scm_t_bits)(data2), (scm_t_bits)(data3)); \
-} while (0)
-
-#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \
- return __SCM_smob_answer; \
+#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \
+do \
+ { \
+ register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \
+ z = (scm_smobs[_smobnum].mark \
+ ? scm_i_new_smob_with_mark_proc (tc, (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), \
+ (scm_t_bits)(data3)) \
+ : scm_double_cell ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), \
+ (scm_t_bits)(data3))); \
+ if (scm_smobs[_smobnum].free) \
+ { \
+ GC_finalization_proc _prev_finalizer; \
+ GC_PTR _prev_finalizer_data; \
+ \
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \
+ NULL, \
+ &_prev_finalizer, \
+ &_prev_finalizer_data); \
+ } \
+ } \
+while (0)
+
+#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \
+ do { SCM __SCM_smob_answer; \
+ SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \
+ return __SCM_smob_answer; \
} while (0)
-#define SCM_SMOB_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 16)
-#define SCM_SMOB_DATA(x) (SCM_CELL_WORD_1 (x))
-#define SCM_SMOB_DATA_2(x) (SCM_CELL_WORD_2 (x))
-#define SCM_SMOB_DATA_3(x) (SCM_CELL_WORD_3 (x))
-#define SCM_SET_SMOB_DATA(x, data) (SCM_SET_CELL_WORD_1 ((x), (data)))
-#define SCM_SET_SMOB_DATA_2(x, data) (SCM_SET_CELL_WORD_2 ((x), (data)))
-#define SCM_SET_SMOB_DATA_3(x, data) (SCM_SET_CELL_WORD_3 ((x), (data)))
-#define SCM_SET_SMOB_FLAGS(x, data) (scm_i_set_smob_flags((x),(data)<<16))
-
-#define SCM_SMOB_OBJECT(x) (SCM_CELL_OBJECT_1 (x))
-#define SCM_SMOB_OBJECT_2(x) (SCM_CELL_OBJECT_2 (x))
-#define SCM_SMOB_OBJECT_3(x) (SCM_CELL_OBJECT_3 (x))
-#define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_CELL_OBJECT_1 ((x), (obj)))
-#define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_CELL_OBJECT_2 ((x), (obj)))
-#define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_CELL_OBJECT_3 ((x), (obj)))
-#define SCM_SMOB_OBJECT_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 1))
-#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 2))
-#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 3))
-
+#define SCM_SMOB_DATA_N(x, n) (SCM_CELL_WORD ((x), (n)))
+#define SCM_SET_SMOB_DATA_N(x, n, data) (SCM_SET_CELL_WORD ((x), (n), (data)))
+
+#define SCM_SMOB_DATA_0(x) (SCM_SMOB_DATA_N ((x), 0))
+#define SCM_SMOB_DATA_1(x) (SCM_SMOB_DATA_N ((x), 1))
+#define SCM_SMOB_DATA_2(x) (SCM_SMOB_DATA_N ((x), 2))
+#define SCM_SMOB_DATA_3(x) (SCM_SMOB_DATA_N ((x), 3))
+#define SCM_SET_SMOB_DATA_0(x, data) (SCM_SET_SMOB_DATA_N ((x), 0, (data)))
+#define SCM_SET_SMOB_DATA_1(x, data) (SCM_SET_SMOB_DATA_N ((x), 1, (data)))
+#define SCM_SET_SMOB_DATA_2(x, data) (SCM_SET_SMOB_DATA_N ((x), 2, (data)))
+#define SCM_SET_SMOB_DATA_3(x, data) (SCM_SET_SMOB_DATA_N ((x), 3, (data)))
+
+#define SCM_SMOB_FLAGS(x) (SCM_SMOB_DATA_0 (x) >> 16)
+#define SCM_SMOB_DATA(x) (SCM_SMOB_DATA_1 (x))
+#define SCM_SET_SMOB_FLAGS(x, data) (SCM_SET_SMOB_DATA_0 ((x), (SCM_CELL_TYPE (x)&0xffff)|((data)<<16)))
+#define SCM_SET_SMOB_DATA(x, data) (SCM_SET_SMOB_DATA_1 ((x), (data)))
+
+#define SCM_SMOB_OBJECT_N(x,n) (SCM_CELL_OBJECT ((x), (n)))
+#define SCM_SET_SMOB_OBJECT_N(x,n,obj) (SCM_SET_CELL_OBJECT ((x), (n), (obj)))
+#define SCM_SMOB_OBJECT_N_LOC(x,n) (SCM_CELL_OBJECT_LOC ((x), (n)))
+
+/*#define SCM_SMOB_OBJECT_0(x) (SCM_SMOB_OBJECT_N ((x), 0))*/
+#define SCM_SMOB_OBJECT_1(x) (SCM_SMOB_OBJECT_N ((x), 1))
+#define SCM_SMOB_OBJECT_2(x) (SCM_SMOB_OBJECT_N ((x), 2))
+#define SCM_SMOB_OBJECT_3(x) (SCM_SMOB_OBJECT_N ((x), 3))
+/*#define SCM_SET_SMOB_OBJECT_0(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 0, (obj)))*/
+#define SCM_SET_SMOB_OBJECT_1(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 1, (obj)))
+#define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 2, (obj)))
+#define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 3, (obj)))
+#define SCM_SMOB_OBJECT_0_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 0)))
+#define SCM_SMOB_OBJECT_1_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 1)))
+#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 2)))
+#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 3)))
+
+#define SCM_SMOB_OBJECT(x) (SCM_SMOB_OBJECT_1 (x))
+#define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_SMOB_OBJECT_1 ((x), (obj)))
+#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x)))
+
+
+#define SCM_SMOB_TYPE_MASK 0xffff
+#define SCM_SMOB_TYPE_BITS(tc) (tc)
#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
/* SCM_SMOBNAME can be 0 if name is missing */
SCM_API long scm_numsmob;
SCM_API scm_smob_descriptor scm_smobs[];
-SCM_API void scm_i_set_smob_flags (SCM x, scm_t_bits data);
+SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR data);
\f
SCM_API SCM scm_mark0 (SCM ptr);
SCM_API SCM scm_markcdr (SCM ptr);
SCM_API size_t scm_free0 (SCM ptr);
-SCM_API size_t scm_smob_free (SCM obj);
SCM_API int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
/* The following set of functions is the standard way to create new
#ifndef SCM_SNARF_H
#define SCM_SNARF_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009 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
#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)()
#endif
+#if (defined SCM_ALIGNED) && (SCM_DEBUG_TYPING_STRICTNESS <= 1)
+/* We support static allocation of some `SCM' objects. */
+# define SCM_SUPPORT_STATIC_ALLOCATION
+#endif
+
+/* C preprocessor token concatenation. */
+#define scm_i_paste(x, y) x ## y
+#define scm_i_paste3(a, b, c) a ## b ## c
+
+
+\f
/* Generic macros to be used in user macro definitions.
*
* For example, in order to define a macro which creates ints and
# endif
#endif
-#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+#define SCM_DEFINE_GSUBR(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+#ifdef SCM_SUPPORT_STATIC_ALLOCATION
+
+/* Static subr allocation. */
+#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+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_SUBR (scm_i_paste (FNAME, __subr), \
+ scm_i_paste (FNAME, __name), \
+ REQ, OPT, VAR, &FNAME); \
+ SCM FNAME ARGLIST \
+) \
+SCM_SNARF_INIT( \
+ /* Initialize the procedure name (an interned symbol). */ \
+ scm_i_paste (FNAME, __subr_meta_info)[0] = scm_i_paste (FNAME, __name); \
+ \
+ /* Define the subr. */ \
+ scm_c_define (scm_i_paste (s_, FNAME), scm_i_paste (FNAME, __subr)); \
+) \
+SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+
+#else /* !SCM_SUPPORT_STATIC_ALLOCATION */
+
+/* Always use the generic subr case. */
+#define SCM_DEFINE SCM_DEFINE_GSUBR
+
+#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
+
+
#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
SCM_SNARF_HERE(static const char RANAME[]=STR)\
SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN))
-#define SCM_SYMBOL(c_name, scheme_name) \
-SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name)))
+#ifdef SCM_SUPPORT_STATIC_ALLOCATION
-#define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
-SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name)))
+# define SCM_SYMBOL(c_name, scheme_name) \
+SCM_SNARF_HERE( \
+ SCM_IMMUTABLE_STRING (scm_i_paste (c_name, _string), scheme_name); \
+ static SCM c_name) \
+SCM_SNARF_INIT( \
+ c_name = scm_string_to_symbol (scm_i_paste (c_name, _string)) \
+)
+
+# define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
+SCM_SNARF_HERE( \
+ SCM_IMMUTABLE_STRING (scm_i_paste (c_name, _string), scheme_name); \
+ SCM c_name) \
+SCM_SNARF_INIT( \
+ c_name = scm_string_to_symbol (scm_i_paste (c_name, _string)) \
+)
+
+#else /* !SCM_SUPPORT_STATIC_ALLOCATION */
+
+# define SCM_SYMBOL(c_name, scheme_name) \
+SCM_SNARF_HERE(static SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_from_locale_symbol (scheme_name))
+
+# define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
+SCM_SNARF_HERE(SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_from_locale_symbol (scheme_name))
+
+#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
#define SCM_KEYWORD(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword (scheme_name)))
+SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name))
#define SCM_GLOBAL_KEYWORD(c_name, scheme_name) \
SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword (scheme_name)))
+SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name))
#define SCM_VARIABLE(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));)
+SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, SCM_BOOL_F);)
#define SCM_GLOBAL_VARIABLE(c_name, scheme_name) \
SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));)
+SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, SCM_BOOL_F);)
#define SCM_VARIABLE_INIT(c_name, scheme_name, init_val) \
SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));)
+SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, init_val);)
#define SCM_GLOBAL_VARIABLE_INIT(c_name, scheme_name, init_val) \
SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));)
+SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, init_val);)
#define SCM_MUTEX(c_name) \
SCM_SNARF_HERE(static scm_t_mutex c_name) \
SCM_SNARF_HERE(SCM c_name arglist) \
SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
+\f
+/* Low-level snarfing for static memory allocation. */
+
+#ifdef SCM_SUPPORT_STATIC_ALLOCATION
+
+#define SCM_IMMUTABLE_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
+ static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
+ c_name ## _raw_cell [2] = \
+ { \
+ { SCM_PACK (car), SCM_PACK (cbr) }, \
+ { SCM_PACK (ccr), SCM_PACK (cdr) } \
+ }; \
+ static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_cell)
+
+#define SCM_IMMUTABLE_STRINGBUF(c_name, contents) \
+ static SCM_UNUSED const \
+ struct \
+ { \
+ scm_t_bits word_0; \
+ scm_t_bits word_1; \
+ const char buffer[sizeof (contents)]; \
+ } \
+ c_name = \
+ { \
+ scm_tc7_stringbuf | SCM_I_STRINGBUF_F_SHARED, \
+ sizeof (contents) - 1, \
+ contents \
+ }
+
+#define SCM_IMMUTABLE_STRING(c_name, contents) \
+ SCM_IMMUTABLE_STRINGBUF (scm_i_paste (c_name, _stringbuf), contents); \
+ SCM_IMMUTABLE_DOUBLE_CELL (c_name, \
+ scm_tc7_ro_string, \
+ (scm_t_bits) &scm_i_paste (c_name, \
+ _stringbuf), \
+ (scm_t_bits) 0, \
+ (scm_t_bits) sizeof (contents) - 1)
+
+#define SCM_IMMUTABLE_SUBR(c_name, name, req, opt, rest, fcn) \
+ static SCM_UNUSED SCM scm_i_paste (c_name, _meta_info)[2] = \
+ { \
+ SCM_BOOL_F, /* The name, initialized at run-time. */ \
+ SCM_EOL /* The procedure properties. */ \
+ }; \
+ SCM_IMMUTABLE_DOUBLE_CELL (c_name, \
+ SCM_SUBR_ARITY_TO_TYPE (req, opt, rest), \
+ (scm_t_bits) fcn, \
+ (scm_t_bits) 0 /* no generic */, \
+ (scm_t_bits) & scm_i_paste (c_name, _meta_info));
+
+#endif /* SCM_SUPPORT_STATIC_ALLOCATION */
+
+\f
+/* Documentation. */
#ifdef SCM_MAGIC_SNARF_DOCS
#undef SCM_ASSERT
}
#undef FUNC_NAME
-#ifndef HAVE_INET_ATON
-/* for our definition in inet_aton.c, not usually needed. */
-extern int inet_aton ();
-#endif
-
-SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0,
- (SCM address),
- "Convert an IPv4 Internet address from printable string\n"
- "(dotted decimal notation) to an integer. E.g.,\n\n"
- "@lisp\n"
- "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
- "@end lisp")
-#define FUNC_NAME s_scm_inet_aton
-{
- struct in_addr soka;
- char *c_address;
- int rv;
-
- c_address = scm_to_locale_string (address);
- rv = inet_aton (c_address, &soka);
- free (c_address);
- if (rv == 0)
- SCM_MISC_ERROR ("bad address", SCM_EOL);
- return scm_from_ulong (ntohl (soka.s_addr));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0,
- (SCM inetid),
- "Convert an IPv4 Internet address to a printable\n"
- "(dotted decimal notation) string. E.g.,\n\n"
- "@lisp\n"
- "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
- "@end lisp")
-#define FUNC_NAME s_scm_inet_ntoa
-{
- struct in_addr addr;
- char *s;
- SCM answer;
- addr.s_addr = htonl (SCM_NUM2ULONG (1, inetid));
- s = inet_ntoa (addr);
- answer = scm_from_locale_string (s);
- return answer;
-}
-#undef FUNC_NAME
-
#ifdef HAVE_INET_NETOF
SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0,
(SCM address),
scm_remember_upto_here_1 (src);
}
else
- scm_wrong_type_arg (NULL, 0, src);
+ scm_wrong_type_arg_msg ("scm_to_ipv6", 0, src, "integer");
}
-#ifdef HAVE_INET_PTON
SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
(SCM family, SCM address),
"Convert a string containing a printable network address to\n"
return scm_from_ipv6 ((scm_t_uint8 *) dst);
}
#undef FUNC_NAME
-#endif
-#ifdef HAVE_INET_NTOP
SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0,
(SCM family, SCM address),
"Convert a network address into a printable string.\n"
"@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
"@lisp\n"
"(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n"
- "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n"
- "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n"
+ "(inet-ntop AF_INET6 (- (expt 2 128) 1))\n"
+ " @result{} \"ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\"\n"
"@end lisp")
#define FUNC_NAME s_scm_inet_ntop
{
return scm_from_locale_string (dst);
}
#undef FUNC_NAME
-#endif
#endif /* HAVE_IPV6 */
struct linger opt_linger;
#endif
-#if HAVE_STRUCT_IP_MREQ
+#ifdef HAVE_STRUCT_IP_MREQ
struct ip_mreq opt_mreq;
#endif
}
}
-#if HAVE_STRUCT_IP_MREQ
+#ifdef HAVE_STRUCT_IP_MREQ
if (ilevel == IPPROTO_IP &&
(ioptname == IP_ADD_MEMBERSHIP || ioptname == IP_DROP_MEMBERSHIP))
{
*args = SCM_CDR (*args);
soka = (struct sockaddr_in *) scm_malloc (sizeof (struct sockaddr_in));
-#if HAVE_STRUCT_SOCKADDR_SIN_LEN
+#ifdef HAVE_STRUCT_SOCKADDR_SIN_LEN
soka->sin_len = sizeof (struct sockaddr_in);
#endif
soka->sin_family = AF_INET;
}
soka = (struct sockaddr_in6 *) scm_malloc (sizeof (struct sockaddr_in6));
-#if HAVE_STRUCT_SOCKADDR_IN6_SIN6_LEN
+#ifdef HAVE_STRUCT_SOCKADDR_IN6_SIN6_LEN
soka->sin6_len = sizeof (struct sockaddr_in6);
#endif
soka->sin6_family = AF_INET6;
{
struct sockaddr_in6 c_inet6;
- scm_to_ipv6 (c_inet6.sin6_addr.s6_addr, address);
+ scm_to_ipv6 (c_inet6.sin6_addr.s6_addr,
+ SCM_SIMPLE_VECTOR_REF (address, 1));
c_inet6.sin6_port =
htons (scm_to_ushort (SCM_SIMPLE_VECTOR_REF (address, 2)));
c_inet6.sin6_flowinfo =
#define INC inc
#include "libguile/quicksort.i.c"
-static scm_t_trampoline_2
-compare_function (SCM less, unsigned int arg_nr, const char* fname)
-{
- const scm_t_trampoline_2 cmp = scm_trampoline_2 (less);
- SCM_ASSERT_TYPE (cmp != NULL, less, arg_nr, fname, "less predicate");
- return cmp;
-}
-
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
"is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
- const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
size_t vlen, spos, len;
ssize_t vinc;
scm_t_array_handle handle;
len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
if (vinc == 1)
- quicksort1 (velts + spos*vinc, len, cmp, less);
+ quicksort1 (velts + spos*vinc, len, less);
else
- quicksort (velts + spos*vinc, len, vinc, cmp, less);
+ quicksort (velts + spos*vinc, len, vinc, less);
scm_array_handle_release (&handle);
"applied to all elements i - 1 and i")
#define FUNC_NAME s_scm_sorted_p
{
- const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len, j; /* list/vector length, temp j */
SCM item, rest; /* rest of items loop variable */
j = len - 1;
while (j > 0)
{
- if (scm_is_true ((*cmp) (less, SCM_CAR (rest), item)))
+ if (scm_is_true (scm_call_2 (less, SCM_CAR (rest), item)))
return SCM_BOOL_F;
else
{
for (i = 1; i < len; i++, elts += inc)
{
- if (scm_is_true ((*cmp) (less, elts[inc], elts[0])))
+ if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
{
result = SCM_BOOL_F;
break;
return alist;
else
{
- const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
long alen, blen; /* list lengths */
SCM last;
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
- if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
+ if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
build = scm_cons (SCM_CAR (blist), SCM_EOL);
blist = SCM_CDR (blist);
while ((alen > 0) && (blen > 0))
{
SCM_TICK;
- if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
+ if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL));
blist = SCM_CDR (blist);
static SCM
scm_merge_list_x (SCM alist, SCM blist,
long alen, long blen,
- scm_t_trampoline_2 cmp, SCM less)
+ SCM less)
{
SCM build, last;
return alist;
else
{
- if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
+ if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
build = blist;
blist = SCM_CDR (blist);
while ((alen > 0) && (blen > 0))
{
SCM_TICK;
- if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
+ if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
SCM_SETCDR (last, blist);
blist = SCM_CDR (blist);
return alist;
else
{
- const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
long alen, blen; /* list lengths */
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
- return scm_merge_list_x (alist, blist, alen, blen, cmp, less);
+ return scm_merge_list_x (alist, blist, alen, blen, less);
}
}
#undef FUNC_NAME
though it claimed to be.
*/
static SCM
-scm_merge_list_step (SCM * seq, scm_t_trampoline_2 cmp, SCM less, long n)
+scm_merge_list_step (SCM * seq, SCM less, long n)
{
SCM a, b;
{
long mid = n / 2;
SCM_TICK;
- a = scm_merge_list_step (seq, cmp, less, mid);
- b = scm_merge_list_step (seq, cmp, less, n - mid);
- return scm_merge_list_x (a, b, mid, n - mid, cmp, less);
+ a = scm_merge_list_step (seq, less, mid);
+ b = scm_merge_list_step (seq, less, n - mid);
+ return scm_merge_list_x (a, b, mid, n - mid, less);
}
else if (n == 2)
{
SCM y = SCM_CAR (SCM_CDR (*seq));
*seq = SCM_CDR (rest);
SCM_SETCDR (rest, SCM_EOL);
- if (scm_is_true ((*cmp) (less, y, x)))
+ if (scm_is_true (scm_call_2 (less, y, x)))
{
SCM_SETCAR (p, y);
SCM_SETCAR (rest, x);
if (scm_is_pair (items))
{
- const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
- return scm_merge_list_step (&items, cmp, less, len);
+ return scm_merge_list_step (&items, less, len);
}
else if (scm_is_vector (items))
{
static void
scm_merge_vector_x (SCM *vec,
SCM *temp,
- scm_t_trampoline_2 cmp,
SCM less,
size_t low,
size_t mid,
/* Copy while both segments contain more characters */
for (it = low; (i1 <= mid) && (i2 <= high); ++it)
{
- if (scm_is_true ((*cmp) (less, VEC(i2), VEC(i1))))
+ if (scm_is_true (scm_call_2 (less, VEC(i2), VEC(i1))))
temp[it] = VEC(i2++);
else
temp[it] = VEC(i1++);
static void
scm_merge_vector_step (SCM *vec,
SCM *temp,
- scm_t_trampoline_2 cmp,
SCM less,
size_t low,
size_t high,
{
size_t mid = (low + high) / 2;
SCM_TICK;
- scm_merge_vector_step (vec, temp, cmp, less, low, mid, inc);
- scm_merge_vector_step (vec, temp, cmp, less, mid+1, high, inc);
- scm_merge_vector_x (vec, temp, cmp, less, low, mid, high, inc);
+ scm_merge_vector_step (vec, temp, less, low, mid, inc);
+ scm_merge_vector_step (vec, temp, less, mid+1, high, inc);
+ scm_merge_vector_x (vec, temp, less, low, mid, high, inc);
}
} /* scm_merge_vector_step */
"This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort_x
{
- const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len; /* list/vector length */
if (SCM_NULL_OR_NIL_P (items))
if (scm_is_pair (items))
{
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
- return scm_merge_list_step (&items, cmp, less, len);
+ return scm_merge_list_step (&items, less, len);
}
else if (scm_is_vector (items))
{
temp_elts = scm_vector_writable_elements (temp, &temp_handle,
NULL, NULL);
- scm_merge_vector_step (vec_elts, temp_elts, cmp, less, 0, len-1, inc);
+ scm_merge_vector_step (vec_elts, temp_elts, less, 0, len-1, inc);
scm_array_handle_release (&temp_handle);
scm_array_handle_release (&vec_handle);
"This is a stable sort.")
#define FUNC_NAME s_scm_sort_list_x
{
- const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len;
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
- return scm_merge_list_step (&items, cmp, less, len);
+ return scm_merge_list_step (&items, less, len);
}
#undef FUNC_NAME
"list elements. This is a stable sort.")
#define FUNC_NAME s_scm_sort_list
{
- const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len;
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
items = scm_list_copy (items);
- return scm_merge_list_step (&items, cmp, less, len);
+ return scm_merge_list_step (&items, less, len);
}
#undef FUNC_NAME
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008 Free Software Foundation
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/weaks.h"
+#include "libguile/gc.h"
#include "libguile/validate.h"
#include "libguile/srcprop.h"
SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
+SCM scm_source_whash;
#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
-#define SRCPROPPOS(p) (SCM_CELL_WORD(p,1))
+#define SRCPROPPOS(p) (SCM_SMOB_DATA(p))
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
-#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
-#define SRCPROPALIST(p) (SCM_CELL_OBJECT_3(p))
+#define SRCPROPCOPY(p) (SCM_SMOB_OBJECT_2(p))
+#define SRCPROPALIST(p) (SCM_SMOB_OBJECT_3(p))
#define SETSRCPROPBRK(p) \
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
-#define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c)))
+#define SETSRCPROPPOS(p, l, c) (SCM_SET_SMOB_DATA_1 (p, SRCPROPMAKPOS (l, c)))
#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
-#define SETSRCPROPCOPY(p, c) (SCM_SET_CELL_WORD(p, 2, c))
-#define SETSRCPROPALIST(p, l) (SCM_SET_CELL_WORD(p, 3, l))
+#define SETSRCPROPCOPY(p, c) (SCM_SET_SMOB_OBJECT_2 (p, c))
+#define SETSRCPROPALIST(p, l) (SCM_SET_SMOB_OBJECT_3 (p, l))
static SCM scm_srcprops_to_alist (SCM obj);
scm_t_bits scm_tc16_srcprops;
-static SCM
-srcprops_mark (SCM obj)
-{
- scm_gc_mark (SRCPROPCOPY (obj));
- return SRCPROPALIST (obj);
-}
-
static int
srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
{
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
- else if (!scm_is_pair (obj))
- SCM_WRONG_TYPE_ARG (1, obj);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (SRCPROPSP (p))
return scm_srcprops_to_alist (p);
#define FUNC_NAME s_scm_set_source_properties_x
{
SCM handle;
- long line = 0, col = 0;
- SCM fname = SCM_UNDEFINED, copy = SCM_UNDEFINED, breakpoint = SCM_BOOL_F;
- SCM others = SCM_EOL;
- SCM *others_cdrloc = &others;
- int need_srcprops = 0;
- SCM tail, key;
-
SCM_VALIDATE_NIM (1, obj);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
- else if (!scm_is_pair (obj))
- SCM_WRONG_TYPE_ARG(1, obj);
-
- tail = alist;
- while (!scm_is_null (tail))
- {
- key = SCM_CAAR (tail);
- if (scm_is_eq (key, scm_sym_line))
- {
- line = scm_to_long (SCM_CDAR (tail));
- need_srcprops = 1;
- }
- else if (scm_is_eq (key, scm_sym_column))
- {
- col = scm_to_long (SCM_CDAR (tail));
- need_srcprops = 1;
- }
- else if (scm_is_eq (key, scm_sym_filename))
- {
- fname = SCM_CDAR (tail);
- need_srcprops = 1;
- }
- else if (scm_is_eq (key, scm_sym_copy))
- {
- copy = SCM_CDAR (tail);
- need_srcprops = 1;
- }
- else if (scm_is_eq (key, scm_sym_breakpoint))
- {
- breakpoint = SCM_CDAR (tail);
- need_srcprops = 1;
- }
- else
- {
- /* Do we allocate here, or clobber the caller's alist?
-
- Source properties aren't supposed to be used for anything
- except the special properties above, so the mainline case
- is that we never execute this else branch, and hence it
- doesn't matter much.
-
- We choose allocation here, as that seems safer.
- */
- *others_cdrloc = scm_cons (scm_cons (key, SCM_CDAR (tail)),
- SCM_EOL);
- others_cdrloc = SCM_CDRLOC (*others_cdrloc);
- }
- tail = SCM_CDR (tail);
- }
- if (need_srcprops)
- {
- alist = scm_make_srcprops (line, col, fname, copy, others);
- if (scm_is_true (breakpoint))
- SETSRCPROPBRK (alist);
- }
- else
- alist = others;
-
handle = scm_hashq_create_handle_x (scm_source_whash, obj, alist);
SCM_SETCDR (handle, alist);
return alist;
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
- else if (!scm_is_pair (obj))
- SCM_WRONG_TYPE_ARG (1, obj);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (!SRCPROPSP (p))
goto alist;
scm_whash_handle h;
SCM p;
SCM_VALIDATE_NIM (1, obj);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
- else if (!scm_is_pair (obj))
- SCM_WRONG_TYPE_ARG (1, obj);
h = scm_whash_get_handle (scm_source_whash, obj);
if (SCM_WHASHFOUNDP (h))
p = SCM_WHASHREF (scm_source_whash, h);
#undef FUNC_NAME
+SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
+ (SCM xorig, SCM x, SCM y),
+ "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
+ "Any source properties associated with @var{xorig} are also associated\n"
+ "with the new pair.")
+#define FUNC_NAME s_scm_cons_source
+{
+ SCM p, z;
+ z = scm_cons (x, y);
+ /* Copy source properties possibly associated with xorig. */
+ p = scm_whash_lookup (scm_source_whash, xorig);
+ if (scm_is_true (p))
+ scm_whash_insert (scm_source_whash, z, p);
+ return z;
+}
+#undef FUNC_NAME
+
+
void
scm_init_srcprop ()
{
scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
- scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark);
scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
scm_c_define ("source-whash", scm_source_whash);
- scm_last_alist_filename
- = scm_permanent_object (scm_cons (SCM_EOL,
- scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)));
+ scm_last_alist_filename = scm_cons (SCM_EOL,
+ scm_acons (SCM_EOL, SCM_EOL, SCM_EOL));
#include "libguile/srcprop.x"
}
#ifndef SCM_SRCPROP_H
#define SCM_SRCPROP_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009 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
#define scm_whash_handle SCM
-#define scm_whash_get_handle(whash, key) scm_hash_fn_get_handle (whash, key, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_get_handle(whash, key) \
+ scm_hashq_get_handle ((whash), (key))
#define SCM_WHASHFOUNDP(h) (scm_is_true (h))
#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
-#define scm_whash_create_handle(whash, key) scm_hash_fn_create_handle_x (whash, key, SCM_UNSPECIFIED, scm_ihashq, scm_sloppy_assq, 0)
-#define scm_whash_lookup(whash, obj) scm_hash_fn_ref (whash, obj, SCM_BOOL_F, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_create_handle(whash, key) \
+ scm_hashq_create_handle_x ((whash), (key), SCM_UNSPECIFIED)
+#define scm_whash_lookup(whash, obj) \
+ scm_hashq_ref ((whash), (obj), SCM_BOOL_F)
#define scm_whash_insert(whash, key, obj) \
do { \
register SCM w = (whash); \
#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
SCM_API scm_t_bits scm_tc16_srcprops;
+SCM_INTERNAL SCM scm_source_whash;
SCM_API SCM scm_sym_filename;
SCM_API SCM scm_sym_copy;
SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum);
SCM_API SCM scm_source_properties (SCM obj);
SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props);
+SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);
SCM_INTERNAL void scm_init_srcprop (void);
#if SCM_ENABLE_DEPRECATED == 1
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG1, FUNC_NAME);
while (cstart < cend)
{
- res = pred_tramp (char_pred,
+ res = scm_call_1 (char_pred,
SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
break;
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG1, FUNC_NAME);
while (cstart < cend)
{
- res = pred_tramp (char_pred,
+ res = scm_call_1 (char_pred,
SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
size_t clen, i;
SCM res;
SCM ch;
- scm_t_trampoline_1 proc_tramp;
- proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
SCM_ASSERT_RANGE (2, len, scm_to_int (len) >= 0);
clen = scm_to_size_t (len);
i = 0;
while (i < clen)
{
- ch = proc_tramp (proc, scm_from_size_t (i));
+ ch = scm_call_1 (proc, scm_from_size_t (i));
if (!SCM_CHARP (ch))
{
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
cstart++;
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res))
break;
cend--;
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
cstart++;
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res))
break;
cend--;
/* This function compares two substrings, S1 from START1 to END1 and
S2 from START2 to END2, possibly case insensitively, and returns
- one of the parameters LESSTHAN, GREATERTHAN, LONGER, SHORTER, or
- EQUAL depending if S1 is less than S2, greater than S2, longer,
- shorter, or equal. */
+ one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
+ EQUAL depending if S1 is less than S2, greater than S2, shorter,
+ longer, or equal. */
static SCM
compare_strings (const char *fname, int case_insensitive,
SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2,
- SCM lessthan, SCM greaterthan, SCM longer, SCM shorter, SCM equal)
+ SCM lessthan, SCM greaterthan, SCM shorter, SCM longer, SCM equal)
{
size_t cstart1, cend1, cstart2, cend2;
SCM ret;
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
goto found;
cstart++;
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
cend--;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_true (res))
goto found;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
goto found;
cstart++;
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
cend--;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_false (res))
goto found;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
count++;
cstart++;
size_t p;
size_t cstart, cend;
SCM result;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart,
4, end, cend);
p = 0;
while (cstart < cend)
{
- SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
+ SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
cstart++;
#define FUNC_NAME s_scm_string_map_x
{
size_t cstart, cend;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart,
4, end, cend);
while (cstart < cend)
{
- SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
+ SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
s = scm_i_string_start_writing (s);
#define FUNC_NAME s_scm_string_for_each
{
size_t cstart, cend;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart,
4, end, cend);
while (cstart < cend)
{
- proc_tramp (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
+ scm_call_1 (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
cstart++;
}
#define FUNC_NAME s_scm_string_for_each_index
{
size_t cstart, cend;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart,
4, end, cend);
while (cstart < cend)
{
- proc_tramp (proc, scm_from_size_t (cstart));
+ scm_call_1 (proc, scm_from_size_t (cstart));
cstart++;
}
else
{
SCM ls = SCM_EOL;
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
idx = cstart;
while (idx < cend)
{
SCM res, ch;
ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
- res = pred_tramp (char_pred, ch);
+ res = scm_call_1 (char_pred, ch);
if (scm_is_true (res))
ls = scm_cons (ch, ls);
idx++;
else
{
SCM ls = SCM_EOL;
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
idx = cstart;
while (idx < cend)
{
SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
- res = pred_tramp (char_pred, ch);
+ res = scm_call_1 (char_pred, ch);
if (scm_is_false (res))
ls = scm_cons (ch, ls);
idx++;
/* srfi-14.c --- SRFI-14 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2007, 2009 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
#include "libguile.h"
#include "libguile/srfi-14.h"
#include "libguile/strings.h"
+#include "libguile/chars.h"
/* Include the pre-computed standard charset data. */
#include "libguile/srfi-14.i.c"
+scm_t_char_range cs_full_ranges[] = {
+ {0x0000, SCM_CODEPOINT_SURROGATE_START - 1}
+ ,
+ {SCM_CODEPOINT_SURROGATE_END + 1, SCM_CODEPOINT_MAX}
+};
+
+scm_t_char_set cs_full = {
+ 2,
+ cs_full_ranges
+};
+
+
#define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))
#define SCM_CHARSET_SET(cs, idx) \
/* This char is one below the current range. */
if (i > 0 && cs->ranges[i - 1].hi + 1 == n)
{
- /* It is also one above the previous range, so combine them. */
- cs->ranges[i - 1].hi = cs->ranges[i].hi;
- if (i < len - 1)
- memmove (cs->ranges + i, cs->ranges + (i + 1),
- sizeof (scm_t_char_range) * (len - i - 1));
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * len,
- sizeof (scm_t_char_range) * (len -
- 1),
- "character-set");
- cs->len = len - 1;
- return;
+ /* It is also one above the previous range. */
+ /* This is an impossible condition: in the previous
+ iteration, the test for 'one above the current range'
+ should already have inserted the character here. */
+ abort ();
}
else
{
return;
}
+/* Put LO to HI inclusive into charset CS. */
+static void
+scm_i_charset_set_range (scm_t_char_set *cs, scm_t_wchar lo, scm_t_wchar hi)
+{
+ size_t i;
+
+ i = 0;
+ while (i < cs->len)
+ {
+ /* Already in this range */
+ if (cs->ranges[i].lo <= lo && cs->ranges[i].hi >= hi)
+ return;
+
+ /* cur: +---+
+ new: +---+
+ */
+ if (cs->ranges[i].lo - 1 > hi)
+ {
+ /* Add a new range below the current one. */
+ cs->ranges = scm_gc_realloc (cs->ranges,
+ sizeof (scm_t_char_range) * cs->len,
+ sizeof (scm_t_char_range) * (cs->len + 1),
+ "character-set");
+ memmove (cs->ranges + (i + 1), cs->ranges + i,
+ sizeof (scm_t_char_range) * (cs->len - i));
+ cs->ranges[i].lo = lo;
+ cs->ranges[i].hi = hi;
+ cs->len += 1;
+ return;
+ }
+
+ /* cur: +---+ or +---+ or +---+
+ new: +---+ +---+ +---+
+ */
+ if (cs->ranges[i].lo > lo
+ && (cs->ranges[i].lo - 1 <= hi && cs->ranges[i].hi >= hi))
+ {
+ cs->ranges[i].lo = lo;
+ return;
+ }
+
+ /* cur: +---+ or +---+ or +---+
+ new: +---+ +---+ +---+
+ */
+ else if (cs->ranges[i].hi + 1 >= lo && cs->ranges[i].hi < hi)
+ {
+ if (cs->ranges[i].lo > lo)
+ cs->ranges[i].lo = lo;
+ if (cs->ranges[i].hi < hi)
+ cs->ranges[i].hi = hi;
+ while (i < cs->len - 1)
+ {
+ /* cur: --+ +---+
+ new: -----+
+ */
+ if (cs->ranges[i + 1].lo - 1 > hi)
+ break;
+
+ /* cur: --+ +---+ or --+ +---+ or --+ +--+
+ new: -----+ ------+ ---------+
+ */
+ /* Combine this range with the previous one. */
+ if (cs->ranges[i + 1].hi > hi)
+ cs->ranges[i].hi = cs->ranges[i + 1].hi;
+ if (i + 1 < cs->len)
+ memmove (cs->ranges + i + 1, cs->ranges + i + 2,
+ sizeof (scm_t_char_range) * (cs->len - i - 2));
+ cs->ranges = scm_gc_realloc (cs->ranges,
+ sizeof (scm_t_char_range) * cs->len,
+ sizeof (scm_t_char_range) * (cs->len - 1),
+ "character-set");
+ cs->len -= 1;
+ }
+ return;
+ }
+ i ++;
+ }
+
+ /* This is a new range above all previous ranges. */
+ if (cs->len == 0)
+ {
+ cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
+ }
+ else
+ {
+ cs->ranges = scm_gc_realloc (cs->ranges,
+ sizeof (scm_t_char_range) * cs->len,
+ sizeof (scm_t_char_range) * (cs->len + 1),
+ "character-set");
+ }
+ cs->len += 1;
+ cs->ranges[cs->len - 1].lo = lo;
+ cs->ranges[cs->len - 1].hi = hi;
+
+ return;
+}
+
/* If N is in charset CS, remove it. */
void
scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n)
charsets_union (scm_t_char_set *a, scm_t_char_set *b)
{
size_t i = 0;
- scm_t_wchar blo, bhi, n;
+ scm_t_wchar blo, bhi;
if (b->len == 0)
return;
return;
}
- /* This needs optimization. */
while (i < b->len)
{
blo = b->ranges[i].lo;
bhi = b->ranges[i].hi;
- for (n = blo; n <= bhi; n++)
- scm_i_charset_set (a, n);
+ scm_i_charset_set_range (a, blo, bhi);
i++;
}
return;
}
+#define SCM_ADD_RANGE(low, high) \
+ do { \
+ p->ranges[idx].lo = (low); \
+ p->ranges[idx++].hi = (high); \
+ } while (0)
+#define SCM_ADD_RANGE_SKIP_SURROGATES(low, high) \
+ do { \
+ p->ranges[idx].lo = (low); \
+ p->ranges[idx++].hi = SCM_CODEPOINT_SURROGATE_START - 1; \
+ p->ranges[idx].lo = SCM_CODEPOINT_SURROGATE_END + 1; \
+ p->ranges[idx++].hi = (high); \
+ } while (0)
+
+
+
/* Make P the compelement of Q. */
static void
charsets_complement (scm_t_char_set *p, scm_t_char_set *q)
{
int k, idx;
+ idx = 0;
if (q->len == 0)
{
/* Fill with all valid codepoints. */
p->len = 2;
p->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * 2,
"character-set");
- p->ranges[0].lo = 0;
- p->ranges[0].hi = 0xd7ff;
- p->ranges[1].lo = 0xe000;
- p->ranges[1].hi = SCM_CODEPOINT_MAX;
+ SCM_ADD_RANGE_SKIP_SURROGATES (0, SCM_CODEPOINT_MAX);
return;
}
scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len,
"character-set");
+ /* Count the number of ranges needed for the output. */
p->len = 0;
if (q->ranges[0].lo > 0)
p->len++;
if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
p->len++;
- p->len += q->len - 1;
+ p->len += q->len;
p->ranges =
(scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * p->len,
"character-set");
- idx = 0;
if (q->ranges[0].lo > 0)
{
- p->ranges[idx].lo = 0;
- p->ranges[idx++].hi = q->ranges[0].lo - 1;
+ if (q->ranges[0].lo > SCM_CODEPOINT_SURROGATE_END)
+ SCM_ADD_RANGE_SKIP_SURROGATES (0, q->ranges[0].lo - 1);
+ else
+ SCM_ADD_RANGE (0, q->ranges[0].lo - 1);
}
for (k = 1; k < q->len; k++)
{
- p->ranges[idx].lo = q->ranges[k - 1].hi + 1;
- p->ranges[idx++].hi = q->ranges[k].lo - 1;
+ if (q->ranges[k - 1].hi < SCM_CODEPOINT_SURROGATE_START
+ && q->ranges[k].lo - 1 > SCM_CODEPOINT_SURROGATE_END)
+ SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
+ else
+ SCM_ADD_RANGE (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
}
if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
{
- p->ranges[idx].lo = q->ranges[q->len - 1].hi + 1;
- p->ranges[idx].hi = SCM_CODEPOINT_MAX;
+ if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_SURROGATE_START)
+ SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
+ else
+ SCM_ADD_RANGE (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
}
return;
}
+#undef SCM_ADD_RANGE
+#undef SCM_ADD_RANGE_SKIP_SURROGATES
/* Replace A with elements only found in one of A or B. */
static void
return 1;
}
-
-/* Smob free hook for character sets. */
-static size_t
-charset_free (SCM charset)
-{
- scm_t_char_set *cs;
- size_t len = 0;
-
- cs = SCM_CHARSET_DATA (charset);
- if (cs != NULL)
- len = cs->len;
- if (len > 0)
- scm_gc_free (cs->ranges, sizeof (scm_t_char_range) * len,
- "character-set");
-
- cs->ranges = NULL;
- cs->len = 0;
-
- scm_gc_free (cs, sizeof (scm_t_char_set), "character-set");
-
- scm_remember_upto_here_1 (charset);
-
- return 0;
-}
-
-
/* Smob print hook for character sets cursors. */
static int
charset_cursor_print (SCM cursor, SCM port,
return 1;
}
-/* Smob free hook for character sets. */
-static size_t
-charset_cursor_free (SCM charset)
-{
- scm_t_char_set_cursor *cur;
-
- cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (charset);
- scm_gc_free (cur, sizeof (scm_t_char_set_cursor), "charset-cursor");
- scm_remember_upto_here_1 (charset);
-
- return 0;
-}
-
/* Create a new, empty character set. */
static SCM
}
SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor, cur_data);
}
-
#undef FUNC_NAME
SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
return SCM_MAKE_CHAR (cur_data->n);
}
-
#undef FUNC_NAME
return cursor;
}
-
#undef FUNC_NAME
return SCM_BOOL_F;
}
-
#undef FUNC_NAME
return SCM_UNSPECIFIED;
}
-
#undef FUNC_NAME
return ret;
}
-
#undef FUNC_NAME
}
return ret;
}
-
#undef FUNC_NAME
for (k = 0; k < p->len; k++)
for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
{
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
if (scm_is_true (res))
SCM_CHARSET_SET (base_cs, n);
}
return base_cs;
}
-
#undef FUNC_NAME
-SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
- (SCM lower, SCM upper, SCM error, SCM base_cs),
- "Return a character set containing all characters whose\n"
- "character codes lie in the half-open range\n"
- "[@var{lower},@var{upper}).\n"
- "\n"
- "If @var{error} is a true value, an error is signalled if the\n"
- "specified range contains characters which are not contained in\n"
- "the implemented character range. If @var{error} is @code{#f},\n"
- "these characters are silently left out of the resultung\n"
- "character set.\n"
- "\n"
- "The characters in @var{base_cs} are added to the result, if\n"
- "given.")
-#define FUNC_NAME s_scm_ucs_range_to_char_set
+/* Return a character set containing all the characters from [LOWER,UPPER),
+ giving range errors if ERROR, adding chars from BASE_CS, and recycling
+ BASE_CS if REUSE is true. */
+static SCM
+scm_i_ucs_range_to_char_set (const char *FUNC_NAME, SCM lower, SCM upper,
+ SCM error, SCM base_cs, int reuse)
{
SCM cs;
size_t clower, cupper;
clower = scm_to_size_t (lower);
- cupper = scm_to_size_t (upper);
+ cupper = scm_to_size_t (upper) - 1;
SCM_ASSERT_RANGE (2, upper, cupper >= clower);
if (!SCM_UNBNDP (error))
{
{
SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
+ if (clower < SCM_CODEPOINT_SURROGATE_START
+ && cupper > SCM_CODEPOINT_SURROGATE_END)
+ scm_error(scm_out_of_range_key,
+ FUNC_NAME, "invalid range - contains surrogate characters: ~S to ~S",
+ scm_list_2 (lower, upper), scm_list_1 (upper));
}
}
- if (clower > 0x10FFFF)
- clower = 0x10FFFF;
- if (cupper > 0x10FFFF)
- cupper = 0x10FFFF;
+
if (SCM_UNBNDP (base_cs))
cs = make_char_set (FUNC_NAME);
else
{
- SCM_VALIDATE_SMOB (4, base_cs, charset);
- cs = scm_char_set_copy (base_cs);
+ SCM_VALIDATE_SMOB (3, base_cs, charset);
+ if (reuse)
+ cs = base_cs;
+ else
+ cs = scm_char_set_copy (base_cs);
}
- /* It not be difficult to write a more optimized version of the
- following. */
- while (clower < cupper)
+
+ if ((clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
+ && (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END))
+ return cs;
+
+ if (clower > SCM_CODEPOINT_MAX)
+ clower = SCM_CODEPOINT_MAX;
+ if (clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
+ clower = SCM_CODEPOINT_SURROGATE_END + 1;
+ if (cupper > SCM_CODEPOINT_MAX)
+ cupper = SCM_CODEPOINT_MAX;
+ if (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END)
+ cupper = SCM_CODEPOINT_SURROGATE_START - 1;
+ if (clower < SCM_CODEPOINT_SURROGATE_START && cupper > SCM_CODEPOINT_SURROGATE_END)
{
- SCM_CHARSET_SET (cs, clower);
- clower++;
+ scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, SCM_CODEPOINT_SURROGATE_START - 1);
+ scm_i_charset_set_range (SCM_CHARSET_DATA (cs), SCM_CODEPOINT_SURROGATE_END + 1, cupper);
}
+ else
+ scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, cupper);
return cs;
}
+
+SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
+ (SCM lower, SCM upper, SCM error, SCM base_cs),
+ "Return a character set containing all characters whose\n"
+ "character codes lie in the half-open range\n"
+ "[@var{lower},@var{upper}).\n"
+ "\n"
+ "If @var{error} is a true value, an error is signalled if the\n"
+ "specified range contains characters which are not valid\n"
+ "Unicode code points. If @var{error} is @code{#f},\n"
+ "these characters are silently left out of the resultung\n"
+ "character set.\n"
+ "\n"
+ "The characters in @var{base_cs} are added to the result, if\n"
+ "given.")
+#define FUNC_NAME s_scm_ucs_range_to_char_set
+{
+ return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
+ error, base_cs, 0);
+}
#undef FUNC_NAME
"returned.")
#define FUNC_NAME s_scm_ucs_range_to_char_set_x
{
- size_t clower, cupper;
-
- clower = scm_to_size_t (lower);
- cupper = scm_to_size_t (upper);
- SCM_ASSERT_RANGE (2, upper, cupper >= clower);
- if (scm_is_true (error))
- {
- SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
- SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
- }
- if (clower > SCM_CODEPOINT_MAX)
- clower = SCM_CODEPOINT_MAX;
- if (cupper > SCM_CODEPOINT_MAX)
- cupper = SCM_CODEPOINT_MAX;
-
- while (clower < cupper)
- {
- if (SCM_IS_UNICODE_CHAR (clower))
- SCM_CHARSET_SET (base_cs, clower);
- clower++;
- }
- return base_cs;
+ SCM_VALIDATE_SMOB (4, base_cs, charset);
+ return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
+ error, base_cs, 1);
}
#undef FUNC_NAME
return scm_from_int (count);
}
-
#undef FUNC_NAME
result = scm_cons (SCM_MAKE_CHAR (n), result);
return result;
}
-
#undef FUNC_NAME
}
return result;
}
-
#undef FUNC_NAME
}
return SCM_BOOL_T;
}
-
#undef FUNC_NAME
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_SMOB (2, cs, charset);
- cs_data = (scm_t_char_set *) cs;
+ cs_data = SCM_CHARSET_DATA (cs);
+ if (cs_data->len == 0)
+ return SCM_BOOL_T;
for (k = 0; k < cs_data->len; k++)
for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
charsets_complement (p, q);
return res;
}
-
#undef FUNC_NAME
cs = scm_char_set_complement (cs);
return cs;
}
-
#undef FUNC_NAME
cs1 = scm_char_set_union (scm_cons (cs1, rest));
return cs1;
}
-
#undef FUNC_NAME
cs1 = scm_char_set_intersection (scm_cons (cs1, rest));
return cs1;
}
-
#undef FUNC_NAME
cs1 = scm_char_set_difference (cs1, rest);
return cs1;
}
-
#undef FUNC_NAME
(char-set-xor a a a) -> char set #\a
(char-set-xor! a a a) -> char set #\a
*/
- return scm_char_set_xor (scm_cons (cs1, rest));
+ cs1 = scm_char_set_xor (scm_cons (cs1, rest));
+ return cs1;
}
-
#undef FUNC_NAME
cs2 = intersect;
return scm_values (scm_list_2 (cs1, cs2));
}
-
#undef FUNC_NAME
+
\f
/* Standard character sets. */
SCM scm_char_set_blank;
SCM scm_char_set_ascii;
SCM scm_char_set_empty;
+SCM scm_char_set_designated;
SCM scm_char_set_full;
SCM_NEWSMOB (cs, scm_tc16_charset, p);
scm_c_define (name, cs);
- return scm_permanent_object (cs);
+ return cs;
}
-#ifdef SCM_CHARSET_DEBUG
-SCM_DEFINE (scm_debug_char_set, "debug-char-set", 1, 0, 0,
- (SCM charset),
- "Print out the internal C structure of @var{charset}.\n")
-#define FUNC_NAME s_debug_char_set
-{
- int i;
- scm_t_char_set *cs = SCM_CHARSET_DATA (charset);
- fprintf (stderr, "cs %p\n", cs);
- fprintf (stderr, "len %d\n", cs->len);
- fprintf (stderr, "arr %p\n", cs->ranges);
+SCM_DEFINE (scm_sys_char_set_dump, "%char-set-dump", 1, 0, 0, (SCM charset),
+ "Returns an association list containing debugging information\n"
+ "for @var{charset}. The association list has the following entries."
+ "@table @code\n"
+ "@item char-set\n"
+ "The char-set itself.\n"
+ "@item len\n"
+ "The number of character ranges the char-set contains\n"
+ "@item ranges\n"
+ "A list of lists where each sublist a range of code points\n"
+ "and their associated characters"
+ "@end table")
+#define FUNC_NAME s_scm_sys_char_set_dump
+{
+ SCM e1, e2, e3;
+ SCM ranges = SCM_EOL, elt;
+ size_t i;
+ scm_t_char_set *cs;
+ char codepoint_string_lo[9], codepoint_string_hi[9];
+
+ SCM_VALIDATE_SMOB (1, charset, charset);
+ cs = SCM_CHARSET_DATA (charset);
+
+ e1 = scm_cons (scm_from_locale_symbol ("char-set"),
+ charset);
+ e2 = scm_cons (scm_from_locale_symbol ("n"),
+ scm_from_size_t (cs->len));
+
for (i = 0; i < cs->len; i++)
{
- if (cs->ranges[i].lo == cs->ranges[i].hi)
- fprintf (stderr, "%04x\n", cs->ranges[i].lo);
+ if (cs->ranges[i].lo > 0xFFFF)
+ sprintf (codepoint_string_lo, "U+%06x", cs->ranges[i].lo);
+ else
+ sprintf (codepoint_string_lo, "U+%04x", cs->ranges[i].lo);
+ if (cs->ranges[i].hi > 0xFFFF)
+ sprintf (codepoint_string_hi, "U+%06x", cs->ranges[i].hi);
else
- fprintf (stderr, "%04x..%04x\t[%d]\n",
- cs->ranges[i].lo,
- cs->ranges[i].hi, cs->ranges[i].hi - cs->ranges[i].lo + 1);
+ sprintf (codepoint_string_hi, "U+%04x", cs->ranges[i].hi);
+
+ elt = scm_list_4 (SCM_MAKE_CHAR (cs->ranges[i].lo),
+ SCM_MAKE_CHAR (cs->ranges[i].hi),
+ scm_from_locale_string (codepoint_string_lo),
+ scm_from_locale_string (codepoint_string_hi));
+ ranges = scm_append (scm_list_2 (ranges,
+ scm_list_1 (elt)));
}
- printf ("\n");
- return SCM_UNSPECIFIED;
-}
+ e3 = scm_cons (scm_from_locale_symbol ("ranges"),
+ ranges);
+ return scm_list_3 (e1, e2, e3);
+}
#undef FUNC_NAME
-#endif
+
\f
scm_init_srfi_14 (void)
{
scm_tc16_charset = scm_make_smob_type ("character-set", 0);
- scm_set_smob_free (scm_tc16_charset, charset_free);
scm_set_smob_print (scm_tc16_charset, charset_print);
scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0);
- scm_set_smob_free (scm_tc16_charset_cursor, charset_cursor_free);
scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print);
scm_char_set_upper_case =
scm_char_set_blank = define_charset ("char-set:blank", &cs_blank);
scm_char_set_ascii = define_charset ("char-set:ascii", &cs_ascii);
scm_char_set_empty = define_charset ("char-set:empty", &cs_empty);
+ scm_char_set_designated = define_charset ("char-set:designated", &cs_designated);
scm_char_set_full = define_charset ("char-set:full", &cs_full);
#include "libguile/srfi-14.x"
SCM_API SCM scm_char_set_difference_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_xor_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest);
-#if SCM_CHARSET_DEBUG
-SCM_API SCM scm_debug_char_set (SCM cs);
-#endif
+SCM_API SCM scm_sys_char_set_dump (SCM charset);
SCM_API SCM scm_char_set_lower_case;
SCM_API SCM scm_char_set_upper_case;
/* This file is #include'd by srfi-14.c. */
-/* This file was generated from http://unicode.org/Public/UNIDATA/UnicodeData.txt
+/* This file was generated from
+ http://unicode.org/Public/UNIDATA/UnicodeData.txt
with the unidata_to_charset.pl script. */
scm_t_char_range cs_lower_case_ranges[] = {
cs_empty_ranges
};
-scm_t_char_range cs_full_ranges[] = {
+scm_t_char_range cs_designated_ranges[] = {
{0x0000, 0x0377}
,
{0x037a, 0x037e}
,
{0xac00, 0xd7a3}
,
- {0xd800, 0xfa2d}
+ {0xe000, 0xfa2d}
,
{0xfa30, 0xfa6a}
,
{0x100000, 0x10fffd}
};
-scm_t_char_set cs_full = {
+scm_t_char_set cs_designated = {
445,
- cs_full_ranges
+ cs_designated_ranges
};
#include "libguile/_scm.h"
#include "libguile/__scm.h"
+#include "libguile/bdw-gc.h"
#include "libguile/srfi-4.h"
#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
- The vector's length (counted in elements).
- The address of the data area (holding the elements of the
vector). */
-#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u))
-#define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
-#define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u))
+#define SCM_UVEC_TYPE(u) (SCM_SMOB_DATA_1(u))
+#define SCM_UVEC_LENGTH(u) ((size_t)SCM_SMOB_DATA_2(u))
+#define SCM_UVEC_BASE(u) ((void *)SCM_SMOB_DATA_3(u))
/* Symbolic constants encoding the various types of uniform
return result;
}
-/* Mark hook. Only used when U64 and S64 are implemented as SCMs. */
-
-#if SCM_HAVE_T_INT64 == 0
-static SCM
-uvec_mark (SCM uvec)
-{
- if (SCM_UVEC_TYPE (uvec) == SCM_UVEC_U64
- || SCM_UVEC_TYPE (uvec) == SCM_UVEC_S64)
- {
- SCM *ptr = (SCM *)SCM_UVEC_BASE (uvec);
- size_t len = SCM_UVEC_LENGTH (uvec), i;
- for (i = 0; i < len; i++)
- scm_gc_mark (*ptr++);
- }
- return SCM_BOOL_F;
-}
-#endif
-
-/* Smob free hook for uniform numeric vectors. */
-static size_t
-uvec_free (SCM uvec)
-{
- int type = SCM_UVEC_TYPE (uvec);
- scm_gc_free (SCM_UVEC_BASE (uvec),
- SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
- uvec_names[type]);
- return 0;
-}
/* ================================================================ */
/* Utility procedures. */
scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
}
+/* Invoke free(3) on DATA, a user-provided buffer passed to one of the
+ `scm_take_' functions. */
+static void
+free_user_data (GC_PTR data, GC_PTR unused)
+{
+ free (data);
+}
+
static SCM
take_uvec (int type, void *base, size_t len)
{
h->elements = h->writable_elements = SCM_UVEC_BASE (v);
}
-SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_uvec),
+ SCM_SMOB_TYPE_MASK,
uvec_handle_ref, uvec_handle_set,
uvec_get_handle);
{
scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
-#if SCM_HAVE_T_INT64 == 0
- scm_set_smob_mark (scm_tc16_uvec, uvec_mark);
-#endif
- scm_set_smob_free (scm_tc16_uvec, uvec_free);
scm_set_smob_print (scm_tc16_uvec, uvec_print);
#if SCM_HAVE_T_INT64 == 0
- scm_uint64_min =
- scm_permanent_object (scm_from_int (0));
- scm_uint64_max =
- scm_permanent_object (scm_c_read_string ("18446744073709551615"));
- scm_int64_min =
- scm_permanent_object (scm_c_read_string ("-9223372036854775808"));
- scm_int64_max =
- scm_permanent_object (scm_c_read_string ("9223372036854775807"));
+ scm_uint64_min = scm_from_int (0);
+ scm_uint64_max = scm_c_read_string ("18446744073709551615");
+ scm_int64_min = scm_c_read_string ("-9223372036854775808");
+ scm_int64_max = scm_c_read_string ("9223372036854775807");
#endif
#define REGISTER(tag, TAG) \
interface.
*/
-SCM_API size_t scm_uniform_element_size (SCM obj);
+SCM_DEPRECATED size_t scm_uniform_element_size (SCM obj);
#endif
SCM
F(scm_take_,TAG,vector) (CTYPE *data, size_t n)
{
- scm_gc_register_collectable_memory ((void *)data, n*uvec_sizes[TYPE],
- uvec_names[TYPE]);
+ /* The manual says "Return a new uniform numeric vector [...] that uses the
+ memory pointed to by DATA". We *have* to use DATA as the underlying
+ storage; thus we must register a finalizer to eventually free(3) it. */
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalization_data;
+
+ GC_REGISTER_FINALIZER_NO_ORDER (data, free_user_data, 0,
+ &prev_finalizer,
+ &prev_finalization_data);
+
return take_uvec (TYPE, data, n);
}
#ifndef SCM_STACKCHK_H
#define SCM_STACKCHK_H
-/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009 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
*/
#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT
-#ifdef STACK_CHECKING
+#if defined BUILDING_LIBGUILE && defined STACK_CHECKING
# if SCM_STACK_GROWS_UP
# define SCM_STACK_OVERFLOW_P(s)\
(SCM_STACK_PTR (s) \
}
#else
# define SCM_CHECK_STACK /**/
-#endif /* STACK_CHECKING */
+#endif
SCM_API int scm_stack_checking_enabled_p;
-/* Representation of stack frame debug information
- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
- *
- * 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
- */
-
-
-\f
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/_scm.h"
-#include "libguile/eval.h"
-#include "libguile/debug.h"
-#include "libguile/continuations.h"
-#include "libguile/struct.h"
-#include "libguile/macros.h"
-#include "libguile/procprop.h"
-#include "libguile/modules.h"
-#include "libguile/root.h"
-#include "libguile/strings.h"
-#include "libguile/vm.h" /* to capture vm stacks */
-#include "libguile/frames.h" /* vm frames */
-
-#include "libguile/validate.h"
-#include "libguile/stacks.h"
-#include "libguile/private-options.h"
-
-
-\f
-/* {Frames and stacks}
- *
- * The debugging evaluator creates debug frames on the stack. These
- * are linked from the innermost frame and outwards. The last frame
- * created can always be accessed as SCM_LAST_DEBUG_FRAME.
- * Continuations contain a pointer to the innermost debug frame on the
- * continuation stack.
- *
- * Each debug frame contains a set of flags and information about one
- * or more stack frames. The case of multiple frames occurs due to
- * tail recursion. The maximal number of stack frames which can be
- * recorded in one debug frame can be set dynamically with the debug
- * option FRAMES.
- *
- * Stack frame information is of two types: eval information (the
- * expression being evaluated and its environment) and apply
- * information (the procedure being applied and its arguments). A
- * stack frame normally corresponds to an eval/apply pair, but macros
- * and special forms (which are implemented as macros in Guile) only
- * have eval information and apply calls leads to apply only frames.
- *
- * Since we want to record the total stack information and later
- * manipulate this data at the scheme level in the debugger, we need
- * to transform it into a new representation. In the following code
- * section you'll find the functions implementing this data type.
- *
- * Representation:
- *
- * The stack is represented as a struct with an id slot and a tail
- * array of scm_t_info_frame structs.
- *
- * A frame is represented as a pair where the car contains a stack and
- * the cdr an inum. The inum is an index to the first SCM value of
- * the scm_t_info_frame struct.
- *
- * Stacks
- * Constructor
- * make-stack
- * Selectors
- * stack-id
- * stack-ref
- * Inspector
- * stack-length
- *
- * Frames
- * Constructor
- * last-stack-frame
- * Selectors
- * frame-number
- * frame-source
- * frame-procedure
- * frame-arguments
- * frame-previous
- * frame-next
- * Predicates
- * frame-real?
- * frame-procedure?
- * frame-evaluating-args?
- * frame-overflow? */
-
-\f
-
-/* Some auxiliary functions for reading debug frames off the stack.
- */
-
-/* Stacks often contain pointers to other items on the stack; for
- example, each scm_t_debug_frame structure contains a pointer to the
- next frame out. When we capture a continuation, we copy the stack
- into the heap, and just leave all the pointers unchanged. This
- makes it simple to restore the continuation --- just copy the stack
- back! However, if we retrieve a pointer from the heap copy to
- another item that was originally on the stack, we have to add an
- offset to the pointer to discover the new referent.
-
- If PTR is a pointer retrieved from a continuation, whose original
- target was on the stack, and OFFSET is the appropriate offset from
- the original stack to the continuation, then RELOC_MUMBLE (PTR,
- OFFSET) is a pointer to the copy in the continuation of the
- original referent, cast to an scm_debug_MUMBLE *. */
-#define RELOC_INFO(ptr, offset) \
- ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
-#define RELOC_FRAME(ptr, offset) \
- ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
-
-/* Count number of debug info frames on a stack, beginning with
- * DFRAME. OFFSET is used for relocation of pointers when the stack
- * is read from a continuation.
- */
-static long
-stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
- SCM *id)
-{
- long n;
- for (n = 0;
- dframe && !SCM_VOIDFRAMEP (*dframe);
- dframe = RELOC_FRAME (dframe->prev, offset))
- {
- if (SCM_EVALFRAMEP (*dframe))
- {
- scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- n += (info - vect) / 2 + 1;
- /* Data in the apply part of an eval info frame comes from previous
- stack frame if the scm_t_debug_info vector is overflowed. */
- if ((((info - vect) & 1) == 0)
- && SCM_OVERFLOWP (*dframe)
- && !SCM_UNBNDP (info[1].a.proc))
- ++n;
- }
- else if (SCM_APPLYFRAMEP (*dframe))
- {
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- if (SCM_PROGRAM_P (vect[0].a.proc))
- {
- if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc))
- /* Programs can end up in the debug stack via deval; but we just
- ignore those, because we know that the debugging VM engine
- pushes one dframe per invocation, with the boot program as
- the proc, so we only count those. */
- continue;
- /* count vmframe back to previous boot frame */
- for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe))
- {
- if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
- ++n;
- else
- { /* skip boot frame, cut out of the vm backtrace */
- vmframe = scm_c_vm_frame_prev (vmframe);
- break;
- }
- }
- }
- else
- ++n; /* increment for non-program apply frame */
- }
- else
- ++n;
- }
- if (dframe && SCM_VOIDFRAMEP (*dframe))
- *id = RELOC_INFO(dframe->vect, offset)[0].id;
- return n;
-}
-
-/* Read debug info from DFRAME into IFRAME.
- */
-static void
-read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- scm_t_info_frame *iframe)
-{
- scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
- if (SCM_EVALFRAMEP (*dframe))
- {
- scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- if ((info - vect) & 1)
- {
- /* Debug.vect ends with apply info. */
- --info;
- if (!SCM_UNBNDP (info[1].a.proc))
- {
- flags |= SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- if (!SCM_ARGS_READY_P (*dframe))
- flags |= SCM_FRAMEF_EVAL_ARGS;
- }
- }
- iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
- }
- else
- {
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- flags |= SCM_FRAMEF_PROC;
- iframe->proc = vect[0].a.proc;
- iframe->args = vect[0].a.args;
- }
- iframe->flags = flags;
-}
-
-/* Look up the first body form of the apply closure. We'll use this
- below to prevent it from being displayed.
-*/
-static SCM
-get_applybody ()
-{
- SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F);
- if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var)))
- return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var)));
- else
- return SCM_UNDEFINED;
-}
-
-#define NEXT_FRAME(iframe, n, quit) \
-do { \
- if (SCM_MEMOIZEDP (iframe->source) \
- && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
- { \
- iframe->source = SCM_BOOL_F; \
- if (scm_is_false (iframe->proc)) \
- { \
- --iframe; \
- ++n; \
- } \
- } \
- ++iframe; \
- if (--n == 0) \
- goto quit; \
-} while (0)
-
-
-/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
- * starting with the first stack frame represented by debug frame
- * DFRAME.
- */
-
-static scm_t_bits
-read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- SCM vmframe, long n, scm_t_info_frame *iframes)
-{
- scm_t_info_frame *iframe = iframes;
- scm_t_debug_info *info, *vect;
- static SCM applybody = SCM_UNDEFINED;
-
- /* The value of applybody has to be setup after r4rs.scm has executed. */
- if (SCM_UNBNDP (applybody))
- applybody = get_applybody ();
- for (;
- dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
- dframe = RELOC_FRAME (dframe->prev, offset))
- {
- read_frame (dframe, offset, iframe);
- if (SCM_EVALFRAMEP (*dframe))
- {
- /* If current frame is a macro during expansion, we should
- skip the previously recorded macro transformer
- application frame. */
- if (SCM_MACROEXPP (*dframe) && iframe > iframes)
- {
- *(iframe - 1) = *iframe;
- --iframe;
- }
- info = RELOC_INFO (dframe->info, offset);
- vect = RELOC_INFO (dframe->vect, offset);
- if ((info - vect) & 1)
- --info;
- /* Data in the apply part of an eval info frame comes from
- previous stack frame if the scm_t_debug_info vector is
- overflowed. */
- else if (SCM_OVERFLOWP (*dframe)
- && !SCM_UNBNDP (info[1].a.proc))
- {
- NEXT_FRAME (iframe, n, quit);
- iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- }
- if (SCM_OVERFLOWP (*dframe))
- iframe->flags |= SCM_FRAMEF_OVERFLOW;
- info -= 2;
- NEXT_FRAME (iframe, n, quit);
- while (info >= vect)
- {
- if (!SCM_UNBNDP (info[1].a.proc))
- {
- iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- }
- else
- iframe->flags = SCM_UNPACK (SCM_INUM0);
- iframe->source = scm_make_memoized (info[0].e.exp,
- info[0].e.env);
- info -= 2;
- NEXT_FRAME (iframe, n, quit);
- }
- }
- else if (SCM_PROGRAM_P (iframe->proc))
- {
- if (!SCM_PROGRAM_IS_BOOT (iframe->proc))
- /* Programs can end up in the debug stack via deval; but we just
- ignore those, because we know that the debugging VM engine
- pushes one dframe per invocation, with the boot program as
- the proc, so we only count those. */
- continue;
- for (; scm_is_true (vmframe);
- vmframe = scm_c_vm_frame_prev (vmframe))
- {
- if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
- { /* skip boot frame, back to interpreted frames */
- vmframe = scm_c_vm_frame_prev (vmframe);
- break;
- }
- else
- {
- /* Oh dear, oh dear, oh dear. */
- iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->source = scm_vm_frame_source (vmframe);
- iframe->proc = scm_vm_frame_program (vmframe);
- iframe->args = scm_vm_frame_arguments (vmframe);
- ++iframe;
- if (--n == 0)
- goto quit;
- }
- }
- }
- else
- {
- NEXT_FRAME (iframe, n, quit);
- }
- quit:
- if (iframe > iframes)
- (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
- }
- return iframe - iframes; /* Number of frames actually read */
-}
-
-/* Narrow STACK by cutting away stackframes (mutatingly).
- *
- * Inner frames (most recent) are cut by advancing the frames pointer.
- * Outer frames are cut by decreasing the recorded length.
- *
- * Cut maximally INNER inner frames and OUTER outer frames using
- * the keys INNER_KEY and OUTER_KEY.
- *
- * Frames are cut away starting at the end points and moving towards
- * the center of the stack. The key is normally compared to the
- * operator in application frames. Frames up to and including the key
- * are cut.
- *
- * If INNER_KEY is #t a different scheme is used for inner frames:
- *
- * Frames up to but excluding the first source frame originating from
- * a user module are cut, except for possible application frames
- * between the user frame and the last system frame previously
- * encountered.
- */
-
-static void
-narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
-{
- scm_t_stack *s = SCM_STACK (stack);
- unsigned long int i;
- long n = s->length;
-
- /* Cut inner part. */
- if (scm_is_eq (inner_key, SCM_BOOL_T))
- {
- /* Cut all frames up to user module code */
- for (i = 0; inner; ++i, --inner)
- {
- SCM m = s->frames[i].source;
- if (SCM_MEMOIZEDP (m)
- && !SCM_IMP (SCM_MEMOIZED_ENV (m))
- && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
- {
- /* Back up in order to include any non-source frames */
- while (i > 0)
- {
- m = s->frames[i - 1].source;
- if (SCM_MEMOIZEDP (m))
- break;
-
- m = s->frames[i - 1].proc;
- if (scm_is_true (scm_procedure_p (m))
- && scm_is_true (scm_procedure_property
- (m, scm_sym_system_procedure)))
- break;
-
- --i;
- ++inner;
- }
- break;
- }
- }
- }
- else
- /* Use standard cutting procedure. */
- {
- for (i = 0; inner; --inner)
- if (scm_is_eq (s->frames[i++].proc, inner_key))
- break;
- }
- s->frames = &s->frames[i];
- n -= i;
-
- /* Cut outer part. */
- for (; n && outer; --outer)
- if (scm_is_eq (s->frames[--n].proc, outer_key))
- break;
-
- s->length = n;
-}
-
-\f
-
-/* Stacks
- */
-
-SCM scm_stack_type;
-
-SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a calling stack.")
-#define FUNC_NAME s_scm_stack_p
-{
- return scm_from_bool(SCM_STACKP (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
- (SCM obj, SCM args),
- "Create a new stack. If @var{obj} is @code{#t}, the current\n"
- "evaluation stack is used for creating the stack frames,\n"
- "otherwise the frames are taken from @var{obj} (which must be\n"
- "either a debug object or a continuation).\n\n"
- "@var{args} should be a list containing any combination of\n"
- "integer, procedure and @code{#t} values.\n\n"
- "These values specify various ways of cutting away uninteresting\n"
- "stack frames from the top and bottom of the stack that\n"
- "@code{make-stack} returns. They come in pairs like this:\n"
- "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
- "@var{outer_cut_2} @dots{})}.\n\n"
- "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
- "procedure. @code{#t} means to cut away all frames up to but\n"
- "excluding the first user module frame. An integer means to cut\n"
- "away exactly that number of frames. A procedure means to cut\n"
- "away all frames up to but excluding the application frame whose\n"
- "procedure matches the specified one.\n\n"
- "Each @var{outer_cut_N} can be an integer or a procedure. An\n"
- "integer means to cut away that number of frames. A procedure\n"
- "means to cut away frames down to but excluding the application\n"
- "frame whose procedure matches the specified one.\n\n"
- "If the @var{outer_cut_N} of the last pair is missing, it is\n"
- "taken as 0.")
-#define FUNC_NAME s_scm_make_stack
-{
- long n, size;
- int maxp;
- scm_t_debug_frame *dframe;
- scm_t_info_frame *iframe;
- SCM vmframe;
- long offset = 0;
- SCM stack, id;
- SCM inner_cut, outer_cut;
-
- /* Extract a pointer to the innermost frame of whatever object
- scm_make_stack was given. */
- if (scm_is_eq (obj, SCM_BOOL_T))
- {
- struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
- dframe = scm_i_last_debug_frame ();
- vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
- }
- else if (SCM_DEBUGOBJP (obj))
- {
- dframe = SCM_DEBUGOBJ_FRAME (obj);
- vmframe = SCM_BOOL_F;
- }
- else if (SCM_VM_FRAME_P (obj))
- {
- dframe = NULL;
- vmframe = obj;
- }
- else if (SCM_CONTINUATIONP (obj))
- {
- scm_t_contregs *cont = SCM_CONTREGS (obj);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
- if (!scm_is_null (cont->vm_conts))
- { SCM vm_cont;
- struct scm_vm_cont *data;
- vm_cont = scm_cdr (scm_car (cont->vm_conts));
- data = SCM_VM_CONT_DATA (vm_cont);
- vmframe = scm_c_make_vm_frame (vm_cont,
- data->fp + data->reloc,
- data->sp + data->reloc,
- data->ip,
- data->reloc);
- } else
- vmframe = SCM_BOOL_F;
- }
- else
- {
- SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
- /* not reached */
- }
-
- /* Count number of frames. Also get stack id tag and check whether
- there are more stackframes than we want to record
- (SCM_BACKTRACE_MAXDEPTH). */
- id = SCM_BOOL_F;
- maxp = 0;
- n = stack_depth (dframe, offset, vmframe, &id);
- /* FIXME: redo maxp? */
- size = n * SCM_FRAME_N_SLOTS;
-
- /* Make the stack object. */
- stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL);
- SCM_STACK (stack) -> id = id;
- iframe = &SCM_STACK (stack) -> tail[0];
- SCM_STACK (stack) -> frames = iframe;
- SCM_STACK (stack) -> length = n;
-
- /* Translate the current chain of stack frames into debugging information. */
- n = read_frames (dframe, offset, vmframe, n, iframe);
- if (n != SCM_STACK (stack)->length)
- {
- scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ());
- SCM_STACK (stack)->length = n;
- }
-
- /* Narrow the stack according to the arguments given to scm_make_stack. */
- SCM_VALIDATE_REST_ARGUMENT (args);
- while (n > 0 && !scm_is_null (args))
- {
- inner_cut = SCM_CAR (args);
- args = SCM_CDR (args);
- if (scm_is_null (args))
- {
- outer_cut = SCM_INUM0;
- }
- else
- {
- outer_cut = SCM_CAR (args);
- args = SCM_CDR (args);
- }
-
- narrow_stack (stack,
- scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
- scm_is_integer (inner_cut) ? 0 : inner_cut,
- scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
- scm_is_integer (outer_cut) ? 0 : outer_cut);
-
- n = SCM_STACK (stack) -> length;
- }
-
- if (n > 0 && maxp)
- iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
-
- if (n > 0)
- return stack;
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
- (SCM stack),
- "Return the identifier given to @var{stack} by @code{start-stack}.")
-#define FUNC_NAME s_scm_stack_id
-{
- scm_t_debug_frame *dframe;
- long offset = 0;
- if (scm_is_eq (stack, SCM_BOOL_T))
- {
- dframe = scm_i_last_debug_frame ();
- }
- else if (SCM_DEBUGOBJP (stack))
- {
- dframe = SCM_DEBUGOBJ_FRAME (stack);
- }
- else if (SCM_CONTINUATIONP (stack))
- {
- scm_t_contregs *cont = SCM_CONTREGS (stack);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
- }
- else if (SCM_STACKP (stack))
- {
- return SCM_STACK (stack) -> id;
- }
- else
- {
- SCM_WRONG_TYPE_ARG (1, stack);
- }
-
- while (dframe && !SCM_VOIDFRAMEP (*dframe))
- dframe = RELOC_FRAME (dframe->prev, offset);
- if (dframe && SCM_VOIDFRAMEP (*dframe))
- return RELOC_INFO (dframe->vect, offset)[0].id;
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
- (SCM stack, SCM index),
- "Return the @var{index}'th frame from @var{stack}.")
-#define FUNC_NAME s_scm_stack_ref
-{
- unsigned long int c_index;
-
- SCM_VALIDATE_STACK (1, stack);
- c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
- return scm_cons (stack, index);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
- (SCM stack),
- "Return the length of @var{stack}.")
-#define FUNC_NAME s_scm_stack_length
-{
- SCM_VALIDATE_STACK (1, stack);
- return scm_from_int (SCM_STACK_LENGTH (stack));
-}
-#undef FUNC_NAME
-
-/* Frames
- */
-
-SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a stack frame.")
-#define FUNC_NAME s_scm_frame_p
-{
- return scm_from_bool(SCM_FRAMEP (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
- (SCM obj),
- "Return the last (innermost) frame of @var{obj}, which must be\n"
- "either a debug object or a continuation.")
-#define FUNC_NAME s_scm_last_stack_frame
-{
- scm_t_debug_frame *dframe;
- long offset = 0;
- SCM stack;
-
- if (SCM_DEBUGOBJP (obj))
- {
- dframe = SCM_DEBUGOBJ_FRAME (obj);
- }
- else if (SCM_CONTINUATIONP (obj))
- {
- scm_t_contregs *cont = SCM_CONTREGS (obj);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
- }
- else
- {
- SCM_WRONG_TYPE_ARG (1, obj);
- /* not reached */
- }
-
- if (!dframe || SCM_VOIDFRAMEP (*dframe))
- return SCM_BOOL_F;
-
- stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS),
- SCM_EOL);
- SCM_STACK (stack) -> length = 1;
- SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
- read_frame (dframe, offset,
- (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]);
-
- return scm_cons (stack, SCM_INUM0);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
- (SCM frame),
- "Return the frame number of @var{frame}.")
-#define FUNC_NAME s_scm_frame_number
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_int (SCM_FRAME_NUMBER (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
- (SCM frame),
- "Return the source of @var{frame}.")
-#define FUNC_NAME s_scm_frame_source
-{
- SCM_VALIDATE_FRAME (1, frame);
- return SCM_FRAME_SOURCE (frame);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
- (SCM frame),
- "Return the procedure for @var{frame}, or @code{#f} if no\n"
- "procedure is associated with @var{frame}.")
-#define FUNC_NAME s_scm_frame_procedure
-{
- SCM_VALIDATE_FRAME (1, frame);
- return (SCM_FRAME_PROC_P (frame)
- ? SCM_FRAME_PROC (frame)
- : SCM_BOOL_F);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
- (SCM frame),
- "Return the arguments of @var{frame}.")
-#define FUNC_NAME s_scm_frame_arguments
-{
- SCM_VALIDATE_FRAME (1, frame);
- return SCM_FRAME_ARGS (frame);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
- (SCM frame),
- "Return the previous frame of @var{frame}, or @code{#f} if\n"
- "@var{frame} is the first frame in its stack.")
-#define FUNC_NAME s_scm_frame_previous
-{
- unsigned long int n;
- SCM_VALIDATE_FRAME (1, frame);
- n = scm_to_ulong (SCM_CDR (frame)) + 1;
- if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
- return SCM_BOOL_F;
- else
- return scm_cons (SCM_CAR (frame), scm_from_ulong (n));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0,
- (SCM frame),
- "Return the next frame of @var{frame}, or @code{#f} if\n"
- "@var{frame} is the last frame in its stack.")
-#define FUNC_NAME s_scm_frame_next
-{
- unsigned long int n;
- SCM_VALIDATE_FRAME (1, frame);
- n = scm_to_ulong (SCM_CDR (frame));
- if (n == 0)
- return SCM_BOOL_F;
- else
- return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
- (SCM frame),
- "Return @code{#t} if @var{frame} is a real frame.")
-#define FUNC_NAME s_scm_frame_real_p
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_bool(SCM_FRAME_REAL_P (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
- (SCM frame),
- "Return @code{#t} if a procedure is associated with @var{frame}.")
-#define FUNC_NAME s_scm_frame_procedure_p
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_bool(SCM_FRAME_PROC_P (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
- (SCM frame),
- "Return @code{#t} if @var{frame} contains evaluated arguments.")
-#define FUNC_NAME s_scm_frame_evaluating_args_p
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
- (SCM frame),
- "Return @code{#t} if @var{frame} is an overflow frame.")
-#define FUNC_NAME s_scm_frame_overflow_p
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame));
-}
-#undef FUNC_NAME
-
-\f
-
-void
-scm_init_stacks ()
-{
- scm_stack_type =
- scm_permanent_object
- (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
- SCM_UNDEFINED));
- scm_set_struct_vtable_name_x (scm_stack_type,
- scm_from_locale_symbol ("stack"));
-#include "libguile/stacks.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* A stack holds a frame chain
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
+ *
+ * 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/debug.h"
+#include "libguile/continuations.h"
+#include "libguile/struct.h"
+#include "libguile/macros.h"
+#include "libguile/procprop.h"
+#include "libguile/modules.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vm.h" /* to capture vm stacks */
+#include "libguile/frames.h" /* vm frames */
+
+#include "libguile/validate.h"
+#include "libguile/stacks.h"
+#include "libguile/private-options.h"
+
+
+\f
+/* {Stacks}
+ *
+ * The stack is represented as a struct that holds a frame. The frame itself is
+ * linked to the next frame, or #f.
+ *
+ * Stacks
+ * Constructor
+ * make-stack
+ * Selectors
+ * stack-id
+ * stack-ref
+ * Inspector
+ * stack-length
+ */
+
+\f
+
+static SCM stack_id_with_fp (SCM frame, SCM **fp);
+
+/* Count number of debug info frames on a stack, beginning with FRAME.
+ */
+static long
+stack_depth (SCM frame, SCM *fp)
+{
+ long n;
+ /* count frames, skipping boot frames */
+ for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
+ frame = scm_c_frame_prev (frame))
+ if (!SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+ ++n;
+ return n;
+}
+
+/* Narrow STACK by cutting away stackframes (mutatingly).
+ *
+ * Inner frames (most recent) are cut by advancing the frames pointer.
+ * Outer frames are cut by decreasing the recorded length.
+ *
+ * Cut maximally INNER inner frames and OUTER outer frames using
+ * the keys INNER_KEY and OUTER_KEY.
+ *
+ * Frames are cut away starting at the end points and moving towards
+ * the center of the stack. The key is normally compared to the
+ * operator in application frames. Frames up to and including the key
+ * are cut.
+ *
+ * If INNER_KEY is #t a different scheme is used for inner frames:
+ *
+ * Frames up to but excluding the first source frame originating from
+ * a user module are cut, except for possible application frames
+ * between the user frame and the last system frame previously
+ * encountered.
+ */
+
+static void
+narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
+{
+ unsigned long int len;
+ SCM frame;
+
+ len = SCM_STACK_LENGTH (stack);
+ frame = SCM_STACK_FRAME (stack);
+
+ /* Cut inner part. */
+ if (scm_is_eq (inner_key, SCM_BOOL_T))
+ {
+ /* Cut specified number of frames. */
+ for (; inner && len; --inner)
+ {
+ len--;
+ frame = scm_c_frame_prev (frame);
+ }
+ }
+ else
+ {
+ /* Cut until the given procedure is seen. */
+ for (; inner && len ; --inner)
+ {
+ SCM proc = scm_frame_procedure (frame);
+ len--;
+ frame = scm_c_frame_prev (frame);
+ if (scm_is_eq (proc, inner_key))
+ break;
+ }
+ }
+
+ SCM_SET_STACK_LENGTH (stack, len);
+ SCM_SET_STACK_FRAME (stack, frame);
+
+ /* Cut outer part. */
+ for (; outer && len ; --outer)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ if (scm_is_eq (scm_frame_procedure (frame), outer_key))
+ break;
+ }
+
+ SCM_SET_STACK_LENGTH (stack, len);
+}
+
+\f
+
+/* Stacks
+ */
+
+SCM scm_stack_type;
+
+SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a calling stack.")
+#define FUNC_NAME s_scm_stack_p
+{
+ return scm_from_bool(SCM_STACKP (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
+ (SCM obj, SCM args),
+ "Create a new stack. If @var{obj} is @code{#t}, the current\n"
+ "evaluation stack is used for creating the stack frames,\n"
+ "otherwise the frames are taken from @var{obj} (which must be\n"
+ "either a debug object or a continuation).\n\n"
+ "@var{args} should be a list containing any combination of\n"
+ "integer, procedure and @code{#t} values.\n\n"
+ "These values specify various ways of cutting away uninteresting\n"
+ "stack frames from the top and bottom of the stack that\n"
+ "@code{make-stack} returns. They come in pairs like this:\n"
+ "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
+ "@var{outer_cut_2} @dots{})}.\n\n"
+ "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
+ "procedure. @code{#t} means to cut away all frames up to but\n"
+ "excluding the first user module frame. An integer means to cut\n"
+ "away exactly that number of frames. A procedure means to cut\n"
+ "away all frames up to but excluding the application frame whose\n"
+ "procedure matches the specified one.\n\n"
+ "Each @var{outer_cut_N} can be an integer or a procedure. An\n"
+ "integer means to cut away that number of frames. A procedure\n"
+ "means to cut away frames down to but excluding the application\n"
+ "frame whose procedure matches the specified one.\n\n"
+ "If the @var{outer_cut_N} of the last pair is missing, it is\n"
+ "taken as 0.")
+#define FUNC_NAME s_scm_make_stack
+{
+ long n;
+ int maxp;
+ SCM frame;
+ SCM stack;
+ SCM id, *id_fp;
+ SCM inner_cut, outer_cut;
+
+ /* Extract a pointer to the innermost frame of whatever object
+ scm_make_stack was given. */
+ if (scm_is_eq (obj, SCM_BOOL_T))
+ {
+ SCM cont;
+ struct scm_vm_cont *c;
+
+ cont = scm_cdar (scm_vm_capture_continuations ());
+ c = SCM_VM_CONT_DATA (cont);
+
+ frame = scm_c_make_frame (cont, c->fp + c->reloc,
+ c->sp + c->reloc, c->ip,
+ c->reloc);
+ }
+ else if (SCM_VM_FRAME_P (obj))
+ frame = obj;
+ else if (SCM_CONTINUATIONP (obj))
+ {
+ scm_t_contregs *cont = SCM_CONTREGS (obj);
+ if (!scm_is_null (cont->vm_conts))
+ { SCM vm_cont;
+ struct scm_vm_cont *data;
+ vm_cont = scm_cdr (scm_car (cont->vm_conts));
+ data = SCM_VM_CONT_DATA (vm_cont);
+ frame = scm_c_make_frame (vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ip,
+ data->reloc);
+ } else
+ frame = SCM_BOOL_F;
+ }
+ else
+ {
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
+ /* not reached */
+ }
+
+ if (scm_is_false (frame))
+ return SCM_BOOL_F;
+
+ /* Get ID of the stack corresponding to the given frame. */
+ id = stack_id_with_fp (frame, &id_fp);
+
+ /* Count number of frames. Also get stack id tag and check whether
+ there are more stackframes than we want to record
+ (SCM_BACKTRACE_MAXDEPTH). */
+ id = SCM_BOOL_F;
+ maxp = 0;
+ n = stack_depth (frame, id_fp);
+
+ /* Make the stack object. */
+ stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
+ SCM_SET_STACK_LENGTH (stack, n);
+ SCM_SET_STACK_ID (stack, id);
+ SCM_SET_STACK_FRAME (stack, frame);
+
+ /* Narrow the stack according to the arguments given to scm_make_stack. */
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ while (n > 0 && !scm_is_null (args))
+ {
+ inner_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ if (scm_is_null (args))
+ {
+ outer_cut = SCM_INUM0;
+ }
+ else
+ {
+ outer_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+
+ narrow_stack (stack,
+ scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
+ scm_is_integer (inner_cut) ? 0 : inner_cut,
+ scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
+ scm_is_integer (outer_cut) ? 0 : outer_cut);
+
+ n = SCM_STACK_LENGTH (stack);
+ }
+
+ if (n > 0)
+ return stack;
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
+ (SCM stack),
+ "Return the identifier given to @var{stack} by @code{start-stack}.")
+#define FUNC_NAME s_scm_stack_id
+{
+ SCM frame, *id_fp;
+
+ if (scm_is_eq (stack, SCM_BOOL_T))
+ {
+ struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
+ frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
+ }
+ else if (SCM_VM_FRAME_P (stack))
+ frame = stack;
+ else if (SCM_CONTINUATIONP (stack))
+ {
+ scm_t_contregs *cont = SCM_CONTREGS (stack);
+ if (!scm_is_null (cont->vm_conts))
+ { SCM vm_cont;
+ struct scm_vm_cont *data;
+ vm_cont = scm_cdr (scm_car (cont->vm_conts));
+ data = SCM_VM_CONT_DATA (vm_cont);
+ frame = scm_c_make_frame (vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ip,
+ data->reloc);
+ } else
+ frame = SCM_BOOL_F;
+ }
+ else
+ {
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
+ /* not reached */
+ }
+
+ return stack_id_with_fp (frame, &id_fp);
+}
+#undef FUNC_NAME
+
+static SCM
+stack_id_with_fp (SCM frame, SCM **fp)
+{
+ SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
+
+ if (SCM_VM_CONT_P (holder))
+ {
+ *fp = NULL;
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ *fp = NULL;
+ return SCM_BOOL_F;
+ }
+}
+
+SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
+ (SCM stack, SCM index),
+ "Return the @var{index}'th frame from @var{stack}.")
+#define FUNC_NAME s_scm_stack_ref
+{
+ unsigned long int c_index;
+ SCM frame;
+
+ SCM_VALIDATE_STACK (1, stack);
+ c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
+ frame = SCM_STACK_FRAME (stack);
+ while (c_index--)
+ {
+ frame = scm_c_frame_prev (frame);
+ while (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+ frame = scm_c_frame_prev (frame);
+ }
+ return frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
+ (SCM stack),
+ "Return the length of @var{stack}.")
+#define FUNC_NAME s_scm_stack_length
+{
+ SCM_VALIDATE_STACK (1, stack);
+ return scm_from_long (SCM_STACK_LENGTH (stack));
+}
+#undef FUNC_NAME
+
+\f
+
+void
+scm_init_stacks ()
+{
+ scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
+ SCM_UNDEFINED);
+ scm_set_struct_vtable_name_x (scm_stack_type,
+ scm_from_locale_symbol ("stack"));
+#include "libguile/stacks.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* classes: h_files */
-
-#ifndef SCM_STACKS_H
-#define SCM_STACKS_H
-
-/* Copyright (C) 1995,1996,2000,2001, 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
- */
-
-\f
-
-#include "libguile/__scm.h"
-
-/* {Frames and stacks}
- */
-
-typedef struct scm_t_info_frame {
- /* SCM flags; */
- scm_t_bits flags;
- SCM source;
- SCM proc;
- SCM args;
-} scm_t_info_frame;
-#define SCM_FRAME_N_SLOTS (sizeof (scm_t_info_frame) / sizeof (SCM))
-
-#define SCM_STACK(obj) ((scm_t_stack *) SCM_STRUCT_DATA (obj))
-#define SCM_STACK_LAYOUT "pwuourpW"
-typedef struct scm_t_stack {
- SCM id; /* Stack id */
- scm_t_info_frame *frames; /* Info frames */
- unsigned long length; /* Stack length */
- unsigned long tail_length;
- scm_t_info_frame tail[1];
-} scm_t_stack;
-
-SCM_API SCM scm_stack_type;
-
-#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE (obj), scm_stack_type))
-#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length)
-
-#define SCM_FRAMEP(obj) \
- (scm_is_pair (obj) && SCM_STACKP (SCM_CAR (obj)) \
- && scm_is_unsigned_integer (SCM_CDR (obj), \
- 0, SCM_STACK_LENGTH (SCM_CAR (obj))-1))
-
-#define SCM_FRAME_REF(frame, slot) \
-(SCM_STACK (SCM_CAR (frame)) -> frames[scm_to_size_t (SCM_CDR (frame))].slot)
-
-#define SCM_FRAME_NUMBER(frame) \
-(SCM_BACKWARDS_P \
- ? scm_to_size_t (SCM_CDR (frame)) \
- : (SCM_STACK_LENGTH (SCM_CAR (frame)) \
- - scm_to_size_t (SCM_CDR (frame)) \
- - 1)) \
-
-#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags)
-#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source)
-#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc)
-#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args)
-#define SCM_FRAME_PREV(frame) scm_frame_previous (frame)
-#define SCM_FRAME_NEXT(frame) scm_frame_next (frame)
-
-#define SCM_FRAMEF_VOID (1L << 2)
-#define SCM_FRAMEF_REAL (1L << 3)
-#define SCM_FRAMEF_PROC (1L << 4)
-#define SCM_FRAMEF_EVAL_ARGS (1L << 5)
-#define SCM_FRAMEF_OVERFLOW (1L << 6)
-
-#define SCM_FRAME_VOID_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_VOID)
-#define SCM_FRAME_REAL_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_REAL)
-#define SCM_FRAME_PROC_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_PROC)
-#define SCM_FRAME_EVAL_ARGS_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_EVAL_ARGS)
-#define SCM_FRAME_OVERFLOW_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_OVERFLOW)
-
-\f
-
-SCM_API SCM scm_stack_p (SCM obj);
-SCM_API SCM scm_make_stack (SCM obj, SCM args);
-SCM_API SCM scm_stack_id (SCM stack);
-SCM_API SCM scm_stack_ref (SCM stack, SCM i);
-SCM_API SCM scm_stack_length (SCM stack);
-
-SCM_API SCM scm_frame_p (SCM obj);
-SCM_API SCM scm_last_stack_frame (SCM obj);
-SCM_API SCM scm_frame_number (SCM frame);
-SCM_API SCM scm_frame_source (SCM frame);
-SCM_API SCM scm_frame_procedure (SCM frame);
-SCM_API SCM scm_frame_arguments (SCM frame);
-SCM_API SCM scm_frame_previous (SCM frame);
-SCM_API SCM scm_frame_next (SCM frame);
-SCM_API SCM scm_frame_real_p (SCM frame);
-SCM_API SCM scm_frame_procedure_p (SCM frame);
-SCM_API SCM scm_frame_evaluating_args_p (SCM frame);
-SCM_API SCM scm_frame_overflow_p (SCM frame);
-
-SCM_INTERNAL void scm_init_stacks (void);
-
-#endif /* SCM_STACKS_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* classes: h_files */
+
+#ifndef SCM_STACKS_H
+#define SCM_STACKS_H
+
+/* Copyright (C) 1995,1996,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/frames.h"
+
+/* {Frames and stacks}
+ */
+
+SCM_API SCM scm_stack_type;
+
+#define SCM_STACK_LAYOUT \
+ "pw" /* len */ \
+ "pw" /* id */ \
+ "pw" /* frame */
+
+#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE (obj), scm_stack_type))
+#define SCM_STACK_LENGTH(obj) (scm_to_long (SCM_STRUCT_SLOT_REF (obj,0)))
+#define SCM_SET_STACK_LENGTH(obj,f) (SCM_STRUCT_SLOT_SET (obj,0,scm_from_long (f)))
+#define SCM_STACK_ID(obj) (SCM_STRUCT_SLOT_REF (obj,1))
+#define SCM_SET_STACK_ID(obj,f) (SCM_STRUCT_SLOT_SET (obj,1,f))
+#define SCM_STACK_FRAME(obj) (SCM_STRUCT_SLOT_REF (obj,2))
+#define SCM_SET_STACK_FRAME(obj,f) (SCM_STRUCT_SLOT_SET (obj,2,f))
+
+#define SCM_FRAMEP(obj) (SCM_VM_FRAME_P (obj))
+
+
+\f
+
+SCM_API SCM scm_stack_p (SCM obj);
+SCM_API SCM scm_make_stack (SCM obj, SCM args);
+SCM_API SCM scm_stack_id (SCM stack);
+SCM_API SCM scm_stack_ref (SCM stack, SCM i);
+SCM_API SCM scm_stack_length (SCM stack);
+
+SCM_INTERNAL void scm_init_stacks (void);
+
+#endif /* SCM_STACKS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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
result = filltime (<, zoff, zname);
SCM_CRITICAL_SECTION_END;
- if (zname)
- free (zname);
+
+ free (zname);
return result;
}
#undef FUNC_NAME
result = scm_cons (scm_from_long (itime),
filltime (<, zoff, zname));
- if (zname)
- free (zname);
+ free (zname);
scm_dynwind_end ();
return result;
#include "libguile/generalized-vectors.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
-#include "libguile/dynwind.h"
\f
* cow-strings, but it failed randomly with more than 10 threads, say.
* I couldn't figure out what went wrong, so I used the conservative
* approach implemented below.
- *
- * A stringbuf needs to know its length, but only so that it can be
- * reported when the stringbuf is freed.
- *
- * There are 3 storage strategies for stringbufs: inline, outline, and
- * wide.
*
- * Inline strings are small 8-bit strings stored within the double
- * cell itself. Outline strings are larger 8-bit strings with GC
- * allocated storage. Wide strings are 32-bit strings with allocated
- * storage.
- *
- * There was little value in making wide string inlineable, since
- * there is only room for three inlined 32-bit characters. Thus wide
- * stringbufs are never inlined.
+ * There are 2 storage strategies for stringbufs: 8-bit and wide. 8-bit
+ * strings are ISO-8859-1-encoded strings; wide strings are 32-bit (UCS-4)
+ * strings.
*/
-#define STRINGBUF_F_SHARED 0x100
-#define STRINGBUF_F_INLINE 0x200
-#define STRINGBUF_F_WIDE 0x400 /* If true, strings have UCS-4
- encoding. Otherwise, strings
- are Latin-1. */
+/* The size in words of the stringbuf header (type tag + size). */
+#define STRINGBUF_HEADER_SIZE 2U
+
+#define STRINGBUF_HEADER_BYTES (STRINGBUF_HEADER_SIZE * sizeof (SCM))
+
+#define STRINGBUF_F_SHARED SCM_I_STRINGBUF_F_SHARED
+#define STRINGBUF_F_WIDE SCM_I_STRINGBUF_F_WIDE
#define STRINGBUF_TAG scm_tc7_stringbuf
#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
-#define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
#define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
-#define STRINGBUF_OUTLINE_CHARS(buf) ((unsigned char *) SCM_CELL_WORD_1(buf))
-#define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf))
-#define STRINGBUF_INLINE_CHARS(buf) ((unsigned char *) SCM_CELL_OBJECT_LOC(buf,1))
-#define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16)
-
-#define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \
- ? STRINGBUF_INLINE_CHARS (buf) \
- : STRINGBUF_OUTLINE_CHARS (buf))
+#define STRINGBUF_CHARS(buf) ((unsigned char *) \
+ SCM_CELL_OBJECT_LOC (buf, \
+ STRINGBUF_HEADER_SIZE))
+#define STRINGBUF_LENGTH(buf) (SCM_CELL_WORD_1 (buf))
-#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) SCM_CELL_WORD_1(buf))
-#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
- ? STRINGBUF_INLINE_LENGTH (buf) \
- : STRINGBUF_OUTLINE_LENGTH (buf))
+#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) STRINGBUF_CHARS (buf))
-#define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))
+#define SET_STRINGBUF_SHARED(buf) \
+ do \
+ { \
+ /* Don't modify BUF if it's already marked as shared since it might be \
+ a read-only, statically allocated stringbuf. */ \
+ if (SCM_LIKELY (!STRINGBUF_SHARED (buf))) \
+ SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED); \
+ } \
+ while (0)
-#define SET_STRINGBUF_SHARED(buf) \
- (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
-
-#if SCM_STRING_LENGTH_HISTOGRAM
+#ifdef SCM_STRING_LENGTH_HISTOGRAM
static size_t lenhist[1001];
#endif
can be dropped.
*/
-#if SCM_STRING_LENGTH_HISTOGRAM
+ SCM buf;
+
+#ifdef SCM_STRING_LENGTH_HISTOGRAM
if (len < 1000)
lenhist[len]++;
else
lenhist[1000]++;
#endif
- if (len <= STRINGBUF_MAX_INLINE_LEN-1)
- {
- return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16),
- 0, 0, 0);
- }
- else
- {
- char *mem = scm_gc_malloc (len+1, "string");
- mem[len] = '\0';
- return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem,
- (scm_t_bits) len, (scm_t_bits) 0);
- }
+ buf = PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1,
+ "string"));
+
+ SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG);
+ SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len);
+
+ STRINGBUF_CHARS (buf)[len] = 0;
+
+ return buf;
}
/* Make a stringbuf with space for LEN 32-bit UCS-4-encoded
static SCM
make_wide_stringbuf (size_t len)
{
- scm_t_wchar *mem;
-#if SCM_STRING_LENGTH_HISTOGRAM
+ SCM buf;
+ size_t raw_len;
+
+#ifdef SCM_STRING_LENGTH_HISTOGRAM
if (len < 1000)
lenhist[len]++;
else
lenhist[1000]++;
#endif
- mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
- mem[len] = 0;
- return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_WIDE, (scm_t_bits) mem,
- (scm_t_bits) len, (scm_t_bits) 0);
-}
-
-/* Return a new stringbuf whose underlying storage consists of the LEN+1
- octets pointed to by STR (the last octet is zero). */
-SCM
-scm_i_take_stringbufn (char *str, size_t len)
-{
- scm_gc_register_collectable_memory (str, len + 1, "stringbuf");
-
- return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
- (scm_t_bits) len, (scm_t_bits) 0);
-}
+ raw_len = (len + 1) * sizeof (scm_t_wchar);
+ buf = PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len,
+ "string"));
-SCM
-scm_i_stringbuf_mark (SCM buf)
-{
- return SCM_BOOL_F;
-}
+ SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG | STRINGBUF_F_WIDE);
+ SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len);
-void
-scm_i_stringbuf_free (SCM buf)
-{
- if (!STRINGBUF_INLINE (buf))
- {
- if (!STRINGBUF_WIDE (buf))
- scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
- STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
- else
- scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
- sizeof (scm_t_wchar) * (STRINGBUF_OUTLINE_LENGTH (buf)
- + 1), "string");
- }
+ STRINGBUF_WIDE_CHARS (buf)[len] = 0;
+ return buf;
}
-/* Convert a stringbuf containing 8-bit Latin-1-encoded characters to
- one containing 32-bit UCS-4-encoded characters. */
-static void
-widen_stringbuf (SCM buf)
+/* Return a UCS-4-encoded stringbuf containing the (possibly Latin-1-encoded)
+ characters from BUF. */
+static SCM
+wide_stringbuf (SCM buf)
{
- size_t i, len;
- scm_t_wchar *mem;
+ SCM new_buf;
if (STRINGBUF_WIDE (buf))
- return;
-
- if (STRINGBUF_INLINE (buf))
+ new_buf = buf;
+ else
{
- len = STRINGBUF_INLINE_LENGTH (buf);
+ size_t i, len;
+ scm_t_wchar *mem;
- mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
- for (i = 0; i < len; i++)
- mem[i] =
- (scm_t_wchar) STRINGBUF_INLINE_CHARS (buf)[i];
- mem[len] = 0;
+ len = STRINGBUF_LENGTH (buf);
- SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_INLINE);
- SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE);
- SCM_SET_CELL_WORD_1 (buf, mem);
- SCM_SET_CELL_WORD_2 (buf, len);
- }
- else
- {
- len = STRINGBUF_OUTLINE_LENGTH (buf);
+ new_buf = make_wide_stringbuf (len);
- mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ mem = STRINGBUF_WIDE_CHARS (new_buf);
for (i = 0; i < len; i++)
- mem[i] =
- (scm_t_wchar) STRINGBUF_OUTLINE_CHARS (buf)[i];
+ mem[i] = (scm_t_wchar) STRINGBUF_CHARS (buf)[i];
mem[len] = 0;
-
- scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), len + 1, "string");
-
- SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE);
- SCM_SET_CELL_WORD_1 (buf, mem);
- SCM_SET_CELL_WORD_2 (buf, len);
}
+
+ return new_buf;
}
-/* Convert a stringbuf of 32-bit UCS-4-encoded characters to one
- containing 8-bit Latin-1-encoded characters, if possible. */
-static void
+/* Return a Latin-1-encoded stringbuf containing the (possibly UCS-4-encoded)
+ characters from BUF, if possible. */
+static SCM
narrow_stringbuf (SCM buf)
{
- size_t i, len;
- scm_t_wchar *wmem;
- char *mem;
+ SCM new_buf;
if (!STRINGBUF_WIDE (buf))
- return;
+ new_buf = buf;
+ else
+ {
+ size_t i, len;
+ scm_t_wchar *wmem;
+ unsigned char *mem;
- len = STRINGBUF_OUTLINE_LENGTH (buf);
- i = 0;
- wmem = STRINGBUF_WIDE_CHARS (buf);
- while (i < len)
- if (wmem[i++] > 0xFF)
- return;
+ len = STRINGBUF_LENGTH (buf);
+ wmem = STRINGBUF_WIDE_CHARS (buf);
- mem = scm_gc_malloc (sizeof (char) * (len + 1), "string");
- for (i = 0; i < len; i++)
- mem[i] = (unsigned char) wmem[i];
+ for (i = 0; i < len; i++)
+ if (wmem[i] > 0xFF)
+ /* BUF cannot be narrowed. */
+ return buf;
+
+ new_buf = make_stringbuf (len);
- scm_gc_free (wmem, sizeof (scm_t_wchar) * (len + 1), "string");
+ mem = STRINGBUF_CHARS (new_buf);
+ for (i = 0; i < len; i++)
+ mem[i] = (unsigned char) wmem[i];
+ mem[len] = 0;
+ }
- SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_WIDE);
- SCM_SET_CELL_WORD_1 (buf, mem);
- SCM_SET_CELL_WORD_2 (buf, len);
+ return new_buf;
}
scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+\f
/* Copy-on-write strings.
*/
/* Read-only strings.
*/
-#define RO_STRING_TAG (scm_tc7_string + 0x200)
+#define RO_STRING_TAG scm_tc7_ro_string
#define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG)
/* Mutation-sharing substrings
#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
+SCM scm_nullstr;
+
/* Create a scheme string with space for LEN 8-bit Latin-1-encoded
characters. CHARSP, if not NULL, will be set to location of the
char array. */
return scm_i_substring_shared (str, start, end);
}
-SCM
-scm_i_string_mark (SCM str)
-{
- if (IS_SH_STRING (str))
- return SH_STRING_STRING (str);
- else
- return STRING_STRINGBUF (str);
-}
-
-void
-scm_i_string_free (SCM str)
-{
-}
-
+\f
/* Internal accessors
*/
int
scm_i_try_narrow_string (SCM str)
{
- narrow_stringbuf (STRING_STRINGBUF (str));
+ SET_STRING_STRINGBUF (str, narrow_stringbuf (STRING_STRINGBUF (str)));
return scm_i_is_narrow_string (str);
}
(scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf)
+ STRING_START (str)), len);
}
- scm_i_thread_put_to_sleep ();
+
SET_STRING_STRINGBUF (str, new_buf);
start -= STRING_START (str);
+
+ /* FIXME: The following operations are not atomic, so other threads
+ looking at STR may see an inconsistent state. Nevertheless it can't
+ hurt much since (i) accessing STR while it is being mutated can't
+ yield a crash, and (ii) concurrent accesses to STR should be
+ protected by a mutex at the application level. The latter may not
+ apply when STR != ORIG_STR, though. */
SET_STRING_START (str, 0);
- scm_i_thread_wake_up ();
+ SET_STRING_STRINGBUF (str, new_buf);
buf = new_buf;
scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
{
if (chr > 0xFF && scm_i_is_narrow_string (str))
- widen_stringbuf (STRING_STRINGBUF (str));
+ SET_STRING_STRINGBUF (str, wide_stringbuf (STRING_STRINGBUF (str)));
if (scm_i_is_narrow_string (str))
{
}
}
+\f
/* Symbols.
Basic symbol creation and accessing is done here, the rest is in
SCM buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (buf), name, len);
- return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
- (scm_t_bits) hash, SCM_UNPACK (props));
-}
-
-/* Return a new symbol that uses the LEN bytes pointed to by NAME as its
- underlying storage. */
-SCM
-scm_i_c_take_symbol (char *name, size_t len,
- scm_t_bits flags, unsigned long hash, SCM props)
-{
- SCM buf = scm_i_take_stringbufn (name, len);
-
- return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
- (scm_t_bits) hash, SCM_UNPACK (props));
+ return scm_immutable_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
+ (scm_t_bits) hash, SCM_UNPACK (props));
}
/* Returns the number of characters in SYM. This may be different
scm_list_1 (sym));
}
-SCM
-scm_i_symbol_mark (SCM sym)
-{
- scm_gc_mark (SYMBOL_STRINGBUF (sym));
- return SCM_CELL_OBJECT_3 (sym);
-}
-
-void
-scm_i_symbol_free (SCM sym)
-{
-}
-
SCM
scm_i_symbol_substring (SCM sym, size_t start, size_t end)
{
"The number of characters in this stringbuf\n"
"@item stringbuf-shared\n"
"@code{#t} if this stringbuf is shared\n"
- "@item stringbuf-inline\n"
- "@code{#t} if this stringbuf's characters are stored in the\n"
- "cell itself, or @code{#f} if they were allocated in memory\n"
"@item stringbuf-wide\n"
"@code{#t} if this stringbuf's characters are stored in a\n"
"32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
"@end table")
#define FUNC_NAME s_scm_sys_string_dump
{
- SCM e1, e2, e3, e4, e5, e6, e7, e8, e9, e10;
+ SCM e1, e2, e3, e4, e5, e6, e7, e8, e9;
SCM buf;
SCM_VALIDATE_STRING (1, str);
else
e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
SCM_BOOL_F);
- if (STRINGBUF_INLINE (buf))
- e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
- SCM_BOOL_T);
- else
- e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
- SCM_BOOL_F);
if (STRINGBUF_WIDE (buf))
- e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
- SCM_BOOL_T);
+ e9 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_T);
else
- e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
- SCM_BOOL_F);
+ e9 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_F);
- return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, SCM_UNDEFINED);
+ return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, SCM_UNDEFINED);
}
#undef FUNC_NAME
"The number of characters in this stringbuf\n"
"@item stringbuf-shared\n"
"@code{#t} if this stringbuf is shared\n"
- "@item stringbuf-inline\n"
- "@code{#t} if this stringbuf's characters are stored in the\n"
- "cell itself, or @code{#f} if they were allocated in memory\n"
"@item stringbuf-wide\n"
"@code{#t} if this stringbuf's characters are stored in a\n"
"32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
"@end table")
#define FUNC_NAME s_scm_sys_symbol_dump
{
- SCM e1, e2, e3, e4, e5, e6, e7, e8;
+ SCM e1, e2, e3, e4, e5, e6, e7;
SCM buf;
SCM_VALIDATE_SYMBOL (1, sym);
e1 = scm_cons (scm_from_locale_symbol ("symbol"),
else
e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
SCM_BOOL_F);
- if (STRINGBUF_INLINE (buf))
- e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
- SCM_BOOL_T);
- else
- e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
- SCM_BOOL_F);
if (STRINGBUF_WIDE (buf))
- e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ e7 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
SCM_BOOL_T);
else
- e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ e7 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
SCM_BOOL_F);
- return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, SCM_UNDEFINED);
+ return scm_list_n (e1, e2, e3, e4, e5, e6, e7, SCM_UNDEFINED);
}
#undef FUNC_NAME
-#if SCM_STRING_LENGTH_HISTOGRAM
+#ifdef SCM_STRING_LENGTH_HISTOGRAM
SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "")
#define FUNC_NAME s_scm_sys_stringbuf_hist
if (wide == 0)
{
+ char *buf;
+
result = scm_i_make_string (len, NULL);
result = scm_i_string_start_writing (result);
- char *buf = scm_i_string_writable_chars (result);
+ buf = scm_i_string_writable_chars (result);
while (len > 0 && scm_is_pair (rest))
{
SCM elt = SCM_CAR (rest);
}
else
{
+ scm_t_wchar *buf;
+
result = scm_i_make_wide_string (len, NULL);
result = scm_i_string_start_writing (result);
- scm_t_wchar *buf = scm_i_string_writable_wide_chars (result);
+ buf = scm_i_string_writable_wide_chars (result);
while (len > 0 && scm_is_pair (rest))
{
SCM elt = SCM_CAR (rest);
return IS_STRING (obj);
}
-static SCM
+SCM
scm_from_stringn (const char *str, size_t len, const char *encoding,
scm_t_string_failed_conversion_handler handler)
{
int wide = 0;
SCM res;
+ if (len == 0)
+ return scm_nullstr;
+
if (encoding == NULL)
{
/* If encoding is null, use Latin-1. */
/* Create a new scheme string from the C string STR. The memory of
STR may be used directly as storage for the new string. */
+/* FIXME: GC-wise, the only way to use the memory area pointed to by STR
+ would be to register a finalizer to eventually free(3) STR, which isn't
+ worth it. Should we just deprecate the `scm_take_' functions? */
SCM
scm_take_locale_stringn (char *str, size_t len)
{
- SCM buf, res;
+ SCM res;
- if (len == (size_t) -1)
- len = strlen (str);
- else
- {
- /* Ensure STR is null terminated. A realloc for 1 extra byte should
- often be satisfied from the alignment padding after the block, with
- no actual data movement. */
- str = scm_realloc (str, len + 1);
- str[len] = '\0';
- }
+ res = scm_from_locale_stringn (str, len);
+ free (str);
- buf = scm_i_take_stringbufn (str, len);
- res = scm_double_cell (STRING_TAG,
- SCM_UNPACK (buf), (scm_t_bits) 0, (scm_t_bits) len);
return res;
}
}
char *
-scm_to_locale_stringn (SCM str, size_t * lenp)
+scm_to_locale_stringn (SCM str, size_t *lenp)
{
SCM outport;
scm_t_port *pt;
scm_list_2 (scm_from_locale_string (enc),
str));
}
+ if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ unistring_escapes_to_guile_escapes (&buf, &len);
}
if (lenp)
*lenp = len;
char **
scm_i_allocate_string_pointers (SCM list)
+#define FUNC_NAME "scm_i_allocate_string_pointers"
{
char **result;
int len = scm_ilength (list);
if (len < 0)
scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
- scm_dynwind_begin (0);
-
- result = (char **) scm_malloc ((len + 1) * sizeof (char *));
+ result = scm_gc_malloc ((len + 1) * sizeof (char *),
+ "string pointers");
result[len] = NULL;
- scm_dynwind_unwind_handler (free, result, 0);
/* The list might be have been modified in another thread, so
we check LIST before each access.
*/
for (i = 0; i < len && scm_is_pair (list); i++)
{
- result[i] = scm_to_locale_string (SCM_CAR (list));
+ SCM str;
+ size_t len;
+
+ str = SCM_CAR (list);
+ len = scm_c_string_length (str);
+
+ result[i] = scm_gc_malloc_pointerless (len + 1, "string pointers");
+ memcpy (result[i], scm_i_string_chars (str), len);
+ result[i][len] = '\0';
+
list = SCM_CDR (list);
}
- scm_dynwind_end ();
return result;
}
-
-void
-scm_i_free_string_pointers (char **pointers)
-{
- int i;
-
- for (i = 0; pointers[i]; i++)
- free (pointers[i]);
- free (pointers);
-}
+#undef FUNC_NAME
void
scm_i_get_substring_spec (size_t len,
null-terminated.
*/
if (IS_SH_STRING (str))
- scm_misc_error (NULL,
- "SCM_STRING_CHARS does not work with shared substrings.",
+ scm_misc_error (NULL,
+ "SCM_STRING_CHARS does not work with shared substrings",
SCM_EOL);
/* We explicitly test for read-only strings to produce a better
*/
if (IS_RO_STRING (str))
- scm_misc_error (NULL,
- "SCM_STRING_CHARS does not work with read-only strings.",
+ scm_misc_error (NULL,
+ "SCM_STRING_CHARS does not work with read-only strings",
SCM_EOL);
-
+
/* The following is still wrong, of course...
*/
str = scm_i_string_start_writing (str);
SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE = SCM_ICONVEH_ESCAPE_SEQUENCE
} scm_t_string_failed_conversion_handler;
+SCM_INTERNAL SCM scm_nullstr;
+
SCM_API SCM scm_string_p (SCM x);
SCM_API SCM scm_string (SCM chrs);
SCM_API SCM scm_make_string (SCM k, SCM chr);
SCM_API SCM scm_substring_copy (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_append (SCM args);
+SCM_API SCM scm_from_stringn (const char *str, size_t len,
+ const char *encoding,
+ scm_t_string_failed_conversion_handler
+ handler);
SCM_API SCM scm_c_make_string (size_t len, SCM chr);
SCM_API size_t scm_c_string_length (SCM str);
SCM_API size_t scm_c_symbol_length (SCM sym);
SCM_API SCM scm_makfromstrs (int argc, char **argv);
+\f
+/* internal constants */
+
+/* Type tag for read-only strings. */
+#define scm_tc7_ro_string (scm_tc7_string + 0x200)
+
+/* Flags for shared and wide strings. */
+#define SCM_I_STRINGBUF_F_SHARED 0x100
+#define SCM_I_STRINGBUF_F_WIDE 0x400
+
+
/* internal accessor functions. Arguments must be valid. */
SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap);
SCM_INTERNAL SCM
scm_i_c_make_symbol (const char *name, size_t len,
scm_t_bits flags, unsigned long hash, SCM props);
-SCM_INTERNAL SCM
-scm_i_c_take_symbol (char *name, size_t len,
- scm_t_bits flags, unsigned long hash, SCM props);
SCM_INTERNAL const char *scm_i_symbol_chars (SCM sym);
SCM_INTERNAL const scm_t_wchar *scm_i_symbol_wide_chars (SCM sym);
SCM_INTERNAL size_t scm_i_symbol_length (SCM sym);
SCM_INTERNAL SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);
SCM_INTERNAL scm_t_wchar scm_i_symbol_ref (SCM sym, size_t x);
-/* internal GC functions. */
-
-SCM_INTERNAL SCM scm_i_string_mark (SCM str);
-SCM_INTERNAL SCM scm_i_stringbuf_mark (SCM buf);
-SCM_INTERNAL SCM scm_i_symbol_mark (SCM buf);
-SCM_INTERNAL void scm_i_string_free (SCM str);
-SCM_INTERNAL void scm_i_stringbuf_free (SCM buf);
-SCM_INTERNAL void scm_i_symbol_free (SCM sym);
-
/* internal utility functions. */
SCM_INTERNAL char **scm_i_allocate_string_pointers (SCM list);
-SCM_INTERNAL void scm_i_free_string_pointers (char **pointers);
SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
SCM start, size_t *cstart,
SCM end, size_t *cend);
-SCM_INTERNAL SCM scm_i_take_stringbufn (char *str, size_t len);
/* Debugging functions */
SCM_API SCM scm_sys_string_dump (SCM);
SCM_API SCM scm_sys_symbol_dump (SCM);
-#if SCM_STRING_LENGTH_HISTOGRAM
+#ifdef SCM_STRING_LENGTH_HISTOGRAM
SCM_API SCM scm_sys_stringbuf_hist (void);
#endif
#if SCM_ENABLE_DEPRECATED
-SCM_API int scm_i_deprecated_stringp (SCM obj);
-SCM_API char *scm_i_deprecated_string_chars (SCM str);
-SCM_API size_t scm_i_deprecated_string_length (SCM str);
+SCM_DEPRECATED int scm_i_deprecated_stringp (SCM obj);
+SCM_DEPRECATED char *scm_i_deprecated_string_chars (SCM str);
+SCM_DEPRECATED size_t scm_i_deprecated_string_length (SCM str);
#define SCM_STRINGP(x) scm_i_deprecated_stringp(x)
#define SCM_STRING_CHARS(x) scm_i_deprecated_string_chars(x)
-/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009 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
return SCM_BOOL_F;
}
-SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic equality predicate; return @code{#t} if the two\n"
"strings are the same length and contain the same characters in\n"
"the same positions, otherwise return @code{#f}.\n"
"letters as though they were the same character, but\n"
"@code{string=?} treats upper and lower case as distinct\n"
"characters.")
-#define FUNC_NAME s_scm_string_equal_p
+#define FUNC_NAME s_scm_i_string_equal_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_eq)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_eq);
+}
+#undef FUNC_NAME
+
+SCM scm_string_equal_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_equal_p
{
return srfi13_cmp (s1, s2, scm_string_eq);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case-insensitive string equality predicate; return @code{#t} if\n"
"the two strings are the same length and their component\n"
"characters match (ignoring case) at each position; otherwise\n"
"return @code{#f}.")
-#define FUNC_NAME s_scm_string_ci_equal_p
+#define FUNC_NAME s_scm_i_string_ci_equal_p
{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_eq)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return srfi13_cmp (s1, s2, scm_string_ci_eq);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_less_p, "string<?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM scm_string_ci_equal_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_equal_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_eq);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
"is lexicographically less than @var{s2}.")
-#define FUNC_NAME s_scm_string_less_p
+#define FUNC_NAME s_scm_i_string_less_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_lt)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_lt);
+}
+#undef FUNC_NAME
+
+SCM scm_string_less_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_less_p
{
return srfi13_cmp (s1, s2, scm_string_lt);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_leq_p, "string<=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
"is lexicographically less than or equal to @var{s2}.")
-#define FUNC_NAME s_scm_string_leq_p
+#define FUNC_NAME s_scm_i_string_leq_p
{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_le)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return srfi13_cmp (s1, s2, scm_string_le);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM scm_string_leq_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_leq_p
+{
+ return srfi13_cmp (s1, s2, scm_string_le);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
"is lexicographically greater than @var{s2}.")
-#define FUNC_NAME s_scm_string_gr_p
+#define FUNC_NAME s_scm_i_string_gr_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_gt)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_gt);
+}
+#undef FUNC_NAME
+
+SCM scm_string_gr_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_gr_p
{
return srfi13_cmp (s1, s2, scm_string_gt);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
"is lexicographically greater than or equal to @var{s2}.")
-#define FUNC_NAME s_scm_string_geq_p
+#define FUNC_NAME s_scm_i_string_geq_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ge)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_ge);
+}
+#undef FUNC_NAME
+
+SCM scm_string_geq_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_geq_p
{
return srfi13_cmp (s1, s2, scm_string_ge);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
"@code{#t} if @var{s1} is lexicographically less than @var{s2}\n"
"regardless of case.")
-#define FUNC_NAME s_scm_string_ci_less_p
+#define FUNC_NAME s_scm_i_string_ci_less_p
{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_lt)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return srfi13_cmp (s1, s2, scm_string_ci_lt);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM scm_string_ci_less_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_less_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_lt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
"@code{#t} if @var{s1} is lexicographically less than or equal\n"
"to @var{s2} regardless of case.")
-#define FUNC_NAME s_scm_string_ci_leq_p
+#define FUNC_NAME s_scm_i_string_ci_leq_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_le)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_ci_le);
+}
+#undef FUNC_NAME
+
+SCM scm_string_ci_leq_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_leq_p
{
return srfi13_cmp (s1, s2, scm_string_ci_le);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
"@code{#t} if @var{s1} is lexicographically greater than\n"
"@var{s2} regardless of case.")
-#define FUNC_NAME s_scm_string_ci_gr_p
+#define FUNC_NAME s_scm_i_string_ci_gr_p
{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_gt)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return srfi13_cmp (s1, s2, scm_string_ci_gt);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM scm_string_ci_gr_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_gr_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_gt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
"@code{#t} if @var{s1} is lexicographically greater than or\n"
"equal to @var{s2} regardless of case.")
-#define FUNC_NAME s_scm_string_ci_geq_p
+#define FUNC_NAME s_scm_i_string_ci_geq_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_ge)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_ci_ge);
+}
+#undef FUNC_NAME
+
+SCM scm_string_ci_geq_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_geq_p
{
return srfi13_cmp (s1, s2, scm_string_ci_ge);
}
}
SCM
-scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len, long modes, const char *caller)
+scm_i_mkstrport (SCM pos, const char *utf8_str, size_t str_len, long modes, const char *caller)
{
SCM z, str;
scm_t_port *pt;
to a locale representation for storage. But, since string ports
rely on string functionality for their memory management, we need
to create a new string that has the 8-bit locale representation
- of the underlying string. This violates the guideline that the
- internal encoding of characters in strings is in unicode
- codepoints. */
+ of the underlying string.
+
+ locale_str is already in the locale of the port. */
str = scm_i_make_string (str_len, &buf);
- memcpy (buf, locale_str, str_len);
+ memcpy (buf, utf8_str, str_len);
c_pos = scm_to_unsigned_integer (pos, 0, str_len);
pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
pt->rw_random = 1;
-
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
/* ensure write_pos is writable. */
if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
st_flush (z);
+
+ scm_i_set_port_encoding_x (z, "UTF-8");
+ scm_i_set_conversion_strategy_x (z, SCM_FAILED_CONVERSION_ERROR);
return z;
}
of the underlying string. This violates the guideline that the
internal encoding of characters in strings is in unicode
codepoints. */
- buf = scm_to_locale_stringn (str, &str_len);
+
+ /* String ports are are always initialized with "UTF-8" as their
+ encoding. */
+ buf = scm_to_stringn (str, &str_len, "UTF-8", SCM_FAILED_CONVERSION_ERROR);
z = scm_i_mkstrport (pos, buf, str_len, modes, caller);
free (buf);
return z;
}
-/* create a new string from a string port's buffer. */
+/* Create a new string from a string port's buffer, converting from
+ the port's 8-bit locale-specific representation to the standard
+ string representation. */
SCM scm_strport_to_string (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
st_flush (port);
- str = scm_from_locale_stringn ((char *)pt->read_buf, pt->read_buf_size);
- scm_remember_upto_here_1 (port);
- return str;
-}
-
-/* Create a vector containing the locale representation of the string in the
- port's buffer. */
-SCM scm_strport_to_locale_u8vector (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- SCM vec;
- char *buf;
-
- if (pt->rw_active == SCM_PORT_WRITE)
- st_flush (port);
+ if (pt->read_buf_size == 0)
+ return scm_nullstr;
- buf = scm_malloc (pt->read_buf_size);
- memcpy (buf, pt->read_buf, pt->read_buf_size);
- vec = scm_take_u8vector ((unsigned char *) buf, pt->read_buf_size);
+ if (pt->encoding == NULL)
+ {
+ char *buf;
+ str = scm_i_make_string (pt->read_buf_size, &buf);
+ memcpy (buf, pt->read_buf, pt->read_buf_size);
+ }
+ else
+ str = scm_from_stringn ((char *)pt->read_buf, pt->read_buf_size,
+ pt->encoding, pt->ilseq_handler);
scm_remember_upto_here_1 (port);
- return vec;
+ return str;
}
SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_call_with_output_locale_u8vector, "call-with-output-locale-u8vector", 1, 0, 0,
- (SCM proc),
- "Calls the one-argument procedure @var{proc} with a newly created output\n"
- "port. When the function returns, a vector containing the bytes of a\n"
- "locale representation of the characters written into the port is returned\n")
-#define FUNC_NAME s_scm_call_with_output_locale_u8vector
-{
- SCM p;
-
- p = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_INUM0, SCM_UNDEFINED),
- SCM_OPN | SCM_WRTNG,
- FUNC_NAME);
- scm_call_1 (proc, p);
-
- return scm_get_output_locale_u8vector (p);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0,
(SCM proc),
"Calls the one-argument procedure @var{proc} with a newly created output\n"
}
#undef FUNC_NAME
-SCM_DEFINE (scm_open_input_locale_u8vector, "open-input-locale-u8vector", 1, 0, 0,
- (SCM vec),
- "Take a u8vector containing the bytes of a string encoded in the\n"
- "current locale and return an input port that delivers characters\n"
- "from the string. The port can be closed by\n"
- "@code{close-input-port}, though its storage will be reclaimed\n"
- "by the garbage collector if it becomes inaccessible.")
-#define FUNC_NAME s_scm_open_input_locale_u8vector
-{
- scm_t_array_handle hnd;
- ssize_t inc;
- size_t len;
- const scm_t_uint8 *buf;
-
- buf = scm_u8vector_elements (vec, &hnd, &len, &inc);
- SCM p = scm_i_mkstrport(SCM_INUM0, (const char *) buf, len, SCM_OPN | SCM_RDNG, FUNC_NAME);
- scm_array_handle_release (&hnd);
- return p;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0,
(void),
"Return an output port that will accumulate characters for\n"
#undef FUNC_NAME
-SCM_DEFINE (scm_get_output_locale_u8vector, "get-output-locale-u8vector", 1, 0, 0,
- (SCM port),
- "Given an output port created by @code{open-output-string},\n"
- "return a u8 vector containing the characters of the string\n"
- "encoded in the current locale.")
-#define FUNC_NAME s_scm_get_output_locale_u8vector
-{
- SCM_VALIDATE_OPOUTSTRPORT (1, port);
- return scm_strport_to_locale_u8vector (port);
-}
-#undef FUNC_NAME
-
-
/* Given a null-terminated string EXPR containing a Scheme expression
read it, and return it as an SCM value. */
SCM
{
scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write);
- scm_set_port_mark (tc, scm_markstream);
scm_set_port_end_input (tc, st_end_input);
scm_set_port_flush (tc, st_flush);
scm_set_port_seek (tc, st_seek);
SCM_INTERNAL SCM scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len,
long modes, const char *caller);
SCM_API SCM scm_strport_to_string (SCM port);
-SCM_API SCM scm_strport_to_locale_u8vector (SCM port);
SCM_API SCM scm_object_to_string (SCM obj, SCM printer);
SCM_API SCM scm_call_with_output_string (SCM proc);
-SCM_API SCM scm_call_with_output_locale_u8vector (SCM proc);
SCM_API SCM scm_call_with_input_string (SCM str, SCM proc);
SCM_API SCM scm_open_input_string (SCM str);
-SCM_API SCM scm_open_input_locale_u8vector (SCM str);
SCM_API SCM scm_open_output_string (void);
SCM_API SCM scm_get_output_string (SCM port);
-SCM_API SCM scm_get_output_locale_u8vector (SCM port);
SCM_API SCM scm_c_read_string (const char *expr);
SCM_API SCM scm_c_eval_string (const char *expr);
SCM_API SCM scm_c_eval_string_in_module (const char *expr, SCM module);
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009 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
# include <config.h>
#endif
+#include <alloca.h>
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
#include <string.h>
#endif
+#include "libguile/bdw-gc.h"
+
\f
+/* A needlessly obscure test. */
+#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
+
static SCM required_vtable_fields = SCM_BOOL_F;
-SCM scm_struct_table;
+static SCM required_applicable_fields = SCM_BOOL_F;
+static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
+SCM scm_struct_table = SCM_BOOL_F;
+SCM scm_applicable_struct_vtable_vtable;
+SCM scm_applicable_struct_with_setter_vtable_vtable;
+SCM scm_standard_vtable_vtable;
+
\f
SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
"type, the second a field protection. Allowed types are 'p' for\n"
"GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
"a field that points to the structure itself. Allowed protections\n"
- "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
- "fields. The last field protection specification may be capitalized to\n"
- "indicate that the field is a tail-array.")
+ "are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n"
+ "fields, and 'o' for opaque fields.\n\n"
+ "Hidden fields are writable, but they will not consume an initializer arg\n"
+ "passed to @code{make-struct}. They are useful to add slots to a struct\n"
+ "in a way that preserves backward-compatibility with existing calls to\n"
+ "@code{make-struct}, especially for derived vtables.\n\n"
+ "The last field protection specification may be capitalized to indicate\n"
+ "that the field is a tail-array.")
#define FUNC_NAME s_scm_make_struct_layout
{
SCM new_sym;
- SCM_VALIDATE_STRING (1, fields);
scm_t_wchar c;
+ SCM_VALIDATE_STRING (1, fields);
+
{ /* scope */
size_t len;
int x;
switch (c = scm_i_string_ref (fields, x + 1))
{
case 'w':
+ case 'h':
if (scm_i_string_ref (fields, x) == 's')
SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
case 'r':
\f
+void
+scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
+#define FUNC_NAME "%inherit-vtable-magic"
+{
+ /* Verily, what is the deal here, you ask? Basically, we need to know a couple
+ of properties of structures at runtime. For example, "is this structure a
+ vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
+ Both of these questions also imply a certain layout of the structure. So
+ instead of checking the layout at runtime, what we do is pre-verify the
+ layout -- so that at runtime we can just check the applicable flag and
+ dispatch directly to the Scheme procedure in slot 0.
+ */
+ SCM olayout;
+
+ /* verify that obj is a valid vtable */
+ if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
+ scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
+ scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
+
+ /* if obj's vtable is compatible with the required vtable (class) layout, it
+ is a metaclass */
+ olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
+ if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields),
+ scm_string_length (olayout)))
+ && scm_is_true (scm_string_eq (olayout, required_vtable_fields,
+ scm_from_size_t (0),
+ scm_string_length (required_vtable_fields),
+ scm_from_size_t (0),
+ scm_string_length (required_vtable_fields))))
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+
+ /* finally if obj is an applicable class, verify that its vtable is
+ compatible with the required applicable layout */
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
+ {
+ if (scm_is_false (scm_string_eq (olayout, required_applicable_with_setter_fields,
+ scm_from_size_t (0),
+ scm_from_size_t (4),
+ scm_from_size_t (0),
+ scm_from_size_t (4))))
+ scm_misc_error (FUNC_NAME, "invalid applicable-with-setter struct layout",
+ scm_list_1 (olayout));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE | SCM_VTABLE_FLAG_SETTER);
+ }
+ else if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE))
+ {
+ if (scm_is_false (scm_string_eq (olayout, required_applicable_fields,
+ scm_from_size_t (0),
+ scm_from_size_t (2),
+ scm_from_size_t (0),
+ scm_from_size_t (2))))
+ scm_misc_error (FUNC_NAME, "invalid applicable struct layout",
+ scm_list_1 (olayout));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
+ }
+}
+#undef FUNC_NAME
static void
-scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits)
+scm_struct_init (SCM handle, SCM layout, size_t n_tail,
+ size_t n_inits, scm_t_bits *inits)
{
scm_t_wchar prot = 0;
int n_fields = scm_i_symbol_length (layout) / 2;
int tailp = 0;
int i;
+ size_t inits_idx = 0;
+ scm_t_bits *mem = SCM_STRUCT_DATA (handle);
i = -2;
while (n_fields)
{
tailp = 1;
prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = tail_elts;
- n_fields += tail_elts - 1;
+ *mem++ = (scm_t_bits)n_tail;
+ n_fields += n_tail - 1;
if (n_fields == 0)
break;
}
}
switch (scm_i_symbol_ref (layout, i))
{
-#if 0
- case 'i':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *mem = 0;
- else
- {
- *mem = scm_to_long (SCM_CAR (inits));
- inits = SCM_CDR (inits);
- }
- break;
-#endif
-
case 'u':
- if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
*mem = 0;
else
{
- *mem = scm_to_ulong (SCM_CAR (inits));
- inits = SCM_CDR (inits);
+ *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
+ inits_idx++;
}
break;
case 'p':
- if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
*mem = SCM_UNPACK (SCM_BOOL_F);
else
{
- *mem = SCM_UNPACK (SCM_CAR (inits));
- inits = SCM_CDR (inits);
+ *mem = inits[inits_idx];
+ inits_idx++;
}
break;
-#if 0
- case 'd':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *((double *)mem) = 0.0;
- else
- {
- *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
- inits = SCM_CDR (inits);
- }
- fields_desc += 2;
- break;
-#endif
-
case 's':
*mem = SCM_UNPACK (handle);
break;
"Return @code{#t} iff @var{x} is a vtable structure.")
#define FUNC_NAME s_scm_struct_vtable_p
{
- SCM layout;
- scm_t_bits * mem;
- SCM tmp;
- size_t len;
-
- if (!SCM_STRUCTP (x))
- return SCM_BOOL_F;
-
- layout = SCM_STRUCT_LAYOUT (x);
-
- if (scm_i_symbol_length (layout)
- < scm_i_string_length (required_vtable_fields))
- return SCM_BOOL_F;
+ return scm_from_bool
+ (SCM_STRUCTP (x)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE));
+}
+#undef FUNC_NAME
- len = scm_i_string_length (required_vtable_fields);
- tmp = scm_string_eq (scm_symbol_to_string (layout),
- required_vtable_fields,
- scm_from_size_t (0),
- scm_from_size_t (len),
- scm_from_size_t (0),
- scm_from_size_t (len));
- if (scm_is_false (tmp))
- return SCM_BOOL_F;
- mem = SCM_STRUCT_DATA (x);
+/* Finalization: invoke the finalizer of the struct pointed to by PTR. */
+static void
+struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
+{
+ SCM obj = PTR2SCM (ptr);
+ scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
- return scm_from_bool (scm_is_symbol (SCM_PACK (mem[scm_vtable_index_layout])));
+ if (finalize)
+ finalize (obj);
}
-#undef FUNC_NAME
-
/* All struct data must be allocated at an address whose bottom three
bits are zero. This is because the tag for a struct lives in the
address of that data doesn't end in three zeros, tagging it will
destroy the pointer.
- This function allocates a block of memory, and returns a pointer at
- least scm_struct_n_extra_words words into the block. Furthermore,
- it guarantees that that pointer's least three significant bits are
- all zero.
-
- The argument n_words should be the number of words that should
- appear after the returned address. (That is, it shouldn't include
- scm_struct_n_extra_words.)
-
- This function initializes the following fields of the struct:
-
- scm_struct_i_ptr --- the actual start of the block of memory; the
- address you should pass to 'free' to dispose of the block.
- This field allows us to both guarantee that the returned
- address is divisible by eight, and allow the GC to free the
- block.
+ I suppose we should make it clear here that, the data must be 8-byte aligned,
+ *within* the struct, and the struct itself should be 8-byte aligned. In
+ practice we ensure this because the data starts two words into a struct.
- scm_struct_i_n_words --- the number of words allocated to the
- block, including the extra fields. This is used by the GC.
-
- Ugh. */
+ This function allocates an 8-byte aligned block of memory, whose first word
+ points to the given vtable data, then a data pointer, then n_words of data.
+ */
+SCM
+scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
+{
+ scm_t_bits ret;
+ ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2), "struct");
+ SCM_SET_CELL_WORD_0 (SCM_PACK (ret), (scm_t_bits)vtable_data | scm_tc3_struct);
+ SCM_SET_CELL_WORD_1 (SCM_PACK (ret),
+ (scm_t_bits)SCM_CELL_OBJECT_LOC (SCM_PACK (ret), 2));
+
+ /* vtable_data can be null when making a vtable vtable */
+ if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
+ {
+ /* Register a finalizer for the newly created instance. */
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+ GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret,
+ struct_finalizer_trampoline,
+ NULL,
+ &prev_finalizer,
+ &prev_finalizer_data);
+ }
+ return SCM_PACK (ret);
+}
-scm_t_bits *
-scm_alloc_struct (int n_words, int n_extra, const char *what)
+\f
+SCM
+scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init)
+#define FUNC_NAME "make-struct"
{
- int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7;
- void * block = scm_gc_malloc (size, what);
+ SCM layout;
+ size_t basic_size;
+ SCM obj;
- /* Adjust the pointer to hide the extra words. */
- scm_t_bits * p = (scm_t_bits *) block + n_extra;
+ SCM_VALIDATE_VTABLE (1, vtable);
- /* Adjust it even further so it's aligned on an eight-byte boundary. */
- p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7);
+ layout = SCM_VTABLE_LAYOUT (vtable);
+ basic_size = scm_i_symbol_length (layout) / 2;
- /* Initialize a few fields as described above. */
- p[scm_struct_i_free] = (scm_t_bits) scm_struct_free_standard;
- p[scm_struct_i_ptr] = (scm_t_bits) block;
- p[scm_struct_i_n_words] = n_words;
- p[scm_struct_i_flags] = 0;
+ if (n_tail != 0)
+ {
+ SCM layout_str, last_char;
+
+ if (basic_size == 0)
+ {
+ bad_tail:
+ SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL);
+ }
- return p;
-}
+ layout_str = scm_symbol_to_string (layout);
+ last_char = scm_string_ref (layout_str,
+ scm_from_size_t (2 * basic_size - 1));
+ if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char)))
+ goto bad_tail;
+ }
-void
-scm_struct_free_0 (scm_t_bits * vtable SCM_UNUSED,
- scm_t_bits * data SCM_UNUSED)
-{
-}
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + n_tail);
-void
-scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data)
-{
- size_t n = vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK;
- scm_gc_free (data, n, "struct");
-}
+ scm_struct_init (obj, layout, n_tail, n_init, init);
-void
-scm_struct_free_standard (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
-{
- size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words)
- * sizeof (scm_t_bits) + 7;
- scm_gc_free ((void *) data[scm_struct_i_ptr], n, "heavy struct");
-}
+ /* only check things and inherit magic if the layout was passed as an initarg.
+ something of a hack, but it's for back-compatibility. */
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
+ && scm_is_true (SCM_VTABLE_LAYOUT (obj)))
+ scm_i_struct_inherit_vtable_magic (vtable, obj);
-void
-scm_struct_free_entity (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
-{
- size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
- * sizeof (scm_t_bits) + 7;
- scm_gc_free ((void *) data[scm_struct_i_ptr], n, "entity struct");
+ return obj;
}
+#undef FUNC_NAME
-static void *
-scm_struct_gc_init (void *dummy1 SCM_UNUSED,
- void *dummy2 SCM_UNUSED,
- void *dummy3 SCM_UNUSED)
+SCM
+scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, ...)
{
- scm_i_structs_to_free = SCM_EOL;
- return 0;
-}
+ va_list foo;
+ scm_t_bits *v;
+ size_t i;
-static void *
-scm_free_structs (void *dummy1 SCM_UNUSED,
- void *dummy2 SCM_UNUSED,
- void *dummy3 SCM_UNUSED)
-{
- SCM newchain = scm_i_structs_to_free;
- do
+ v = alloca (sizeof (scm_t_bits) * n_init);
+
+ va_start (foo, init);
+ for (i = 0; i < n_init; i++)
{
- /* Mark vtables in GC chain. GC mark set means delay freeing. */
- SCM chain = newchain;
- while (!scm_is_null (chain))
- {
- SCM vtable = SCM_STRUCT_VTABLE (chain);
- if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain)
- SCM_SET_STRUCT_MARK (vtable);
- chain = SCM_STRUCT_GC_CHAIN (chain);
- }
- /* Free unmarked structs. */
- chain = newchain;
- newchain = SCM_EOL;
- while (!scm_is_null (chain))
- {
- SCM obj = chain;
- chain = SCM_STRUCT_GC_CHAIN (chain);
- if (SCM_STRUCT_MARK_P (obj))
- {
- SCM_CLEAR_STRUCT_MARK (obj);
- SCM_SET_STRUCT_GC_CHAIN (obj, newchain);
- newchain = obj;
- }
- else
- {
- scm_t_bits * vtable_data = SCM_STRUCT_VTABLE_DATA (obj);
- scm_t_bits * data = SCM_STRUCT_DATA (obj);
- scm_t_struct_free free_struct_data
- = ((scm_t_struct_free) vtable_data[scm_struct_i_free]);
- SCM_SET_CELL_TYPE (obj, scm_tc_free_cell);
- free_struct_data (vtable_data, data);
- }
- }
+ v[i] = init;
+ init = va_arg (foo, scm_t_bits);
}
- while (!scm_is_null (newchain));
- return 0;
+ va_end (foo);
+
+ return scm_c_make_structv (vtable, n_tail, n_init, v);
}
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
"successive fields of the structure should be initialized. Only fields\n"
"with protection 'r' or 'w' can be initialized, except for fields of\n"
"type 's', which are automatically initialized to point to the new\n"
- "structure itself; fields with protection 'o' can not be initialized by\n"
+ "structure itself. Fields with protection 'o' can not be initialized by\n"
"Scheme programs.\n\n"
"If fewer optional arguments than initializable fields are supplied,\n"
"fields of type 'p' get default value #f while fields of type 'u' are\n"
"initialized to 0.\n\n"
- "Structs are currently the basic representation for record-like data\n"
- "structures in Guile. The plan is to eventually replace them with a\n"
- "new representation which will at the same time be easier to use and\n"
- "more powerful.\n\n"
"For more information, see the documentation for @code{make-vtable-vtable}.")
#define FUNC_NAME s_scm_make_struct
{
- SCM layout;
- size_t basic_size;
- size_t tail_elts;
- scm_t_bits * data;
- SCM handle;
+ size_t i, n_init;
+ long ilen;
+ scm_t_bits *v;
SCM_VALIDATE_VTABLE (1, vtable);
- SCM_VALIDATE_REST_ARGUMENT (init);
-
- layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]);
- basic_size = scm_i_symbol_length (layout) / 2;
- tail_elts = scm_to_size_t (tail_array_size);
-
- /* A tail array is only allowed if the layout fields string ends in "R",
- "W" or "O". */
- if (tail_elts != 0)
- {
- SCM layout_str, last_char;
-
- if (basic_size == 0)
- {
- bad_tail:
- SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL);
- }
-
- layout_str = scm_symbol_to_string (layout);
- last_char = scm_string_ref (layout_str,
- scm_from_size_t (2 * basic_size - 1));
- if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char)))
- goto bad_tail;
- }
-
- /* In guile 1.8.5 and earlier, everything below was covered by a
- CRITICAL_SECTION lock. This can lead to deadlocks in garbage
- collection, since other threads might be holding the heap_mutex, while
- sleeping on the CRITICAL_SECTION lock. There does not seem to be any
- need for a lock on the section below, as it does not access or update
- any globals, so the critical section has been removed. */
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen;
- if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
- {
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_entity_n_extra_words,
- "entity struct");
- data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
- data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
- }
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
else
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_n_extra_words,
- "struct");
- handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable))
- + scm_tc3_struct),
- (scm_t_bits) data, 0, 0);
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
- scm_struct_init (handle, layout, data, tail_elts, init);
+ for (i = 0; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
- return handle;
+ return scm_c_make_structv (vtable, scm_to_size_t (tail_array_size), n_init, v);
}
#undef FUNC_NAME
SCM fields;
SCM layout;
size_t basic_size;
- size_t tail_elts;
- scm_t_bits *data;
- SCM handle;
+ size_t n_tail, i, n_init;
+ SCM obj;
+ long ilen;
+ scm_t_bits *v;
SCM_VALIDATE_STRING (1, user_fields);
- SCM_VALIDATE_REST_ARGUMENT (init);
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen + 1; /* + 1 for the layout */
+
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
+ else
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
fields = scm_string_append (scm_list_2 (required_vtable_fields,
user_fields));
layout = scm_make_struct_layout (fields);
basic_size = scm_i_symbol_length (layout) / 2;
- tail_elts = scm_to_size_t (tail_array_size);
+ n_tail = scm_to_size_t (tail_array_size);
+
+ i = 0;
+ v[i++] = SCM_UNPACK (layout);
+ for (; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
+
SCM_CRITICAL_SECTION_START;
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_n_extra_words,
- "struct");
- handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct,
- (scm_t_bits) data, 0, 0);
- data [scm_vtable_index_layout] = SCM_UNPACK (layout);
- scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
+ obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
+ /* magic magic magic */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) | scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
- return handle;
+ scm_struct_init (obj, layout, n_tail, n_init, v);
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+ return obj;
}
#undef FUNC_NAME
-static SCM scm_i_vtable_vtable_no_extra_fields;
-
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
"Create a vtable, for creating structures with the given\n"
if (SCM_UNBNDP (printer))
printer = SCM_BOOL_F;
- return scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ return scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_2 (scm_make_struct_layout (fields),
printer));
}
SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
(SCM handle, SCM pos),
- "@deffnx {Scheme Procedure} struct-set! struct n value\n"
- "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
+ "Access the @var{n}th field of @var{struct}.\n\n"
"If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
"If the field is of type 'u', then it can only be set to a non-negative\n"
"integer value small enough to fit in one machine word.")
p = scm_to_size_t (pos);
layout_len = scm_i_symbol_length (layout);
- if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
- /* no extra words */
- n_fields = layout_len / 2;
- else
- n_fields = data[scm_struct_i_n_words];
+ n_fields = layout_len / 2;
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
SCM_ASSERT_RANGE(1, pos, p < n_fields);
scm_t_wchar ref;
field_type = scm_i_symbol_ref (layout, p * 2);
ref = scm_i_symbol_ref (layout, p * 2 + 1);
- if ((ref != 'r') && (ref != 'w'))
+ if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
{
if ((ref == 'R') || (ref == 'W'))
field_type = 'u';
p = scm_to_size_t (pos);
layout_len = scm_i_symbol_length (layout);
- if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
- /* no extra words */
- n_fields = layout_len / 2;
- else
- n_fields = data[scm_struct_i_n_words];
+ n_fields = layout_len / 2;
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
SCM_ASSERT_RANGE (1, pos, p < n_fields);
char set_x;
field_type = scm_i_symbol_ref (layout, p * 2);
set_x = scm_i_symbol_ref (layout, p * 2 + 1);
- if (set_x != 'w')
+ if (set_x != 'w' && set_x != 'h')
SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
}
else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
*/
unsigned long
-scm_struct_ihashq (SCM obj, unsigned long n)
+scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
{
/* The length of the hash table should be a relative prime it's not
necessary to shift down the address. */
obj,
SCM_BOOL_F,
scm_struct_ihashq,
- scm_sloppy_assq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
0);
if (scm_is_false (SCM_CDR (handle)))
SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
SCM name = scm_struct_vtable_name (vtable);
scm_puts ("#<", port);
if (scm_is_true (name))
- scm_display (name, port);
+ {
+ scm_display (name, port);
+ scm_putc (' ', port);
+ }
else
- scm_puts ("struct", port);
- scm_putc (' ', port);
- scm_uintprint (SCM_UNPACK (vtable), 16, port);
- scm_putc (':', port);
+ {
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE))
+ scm_puts ("vtable:", port);
+ else
+ scm_puts ("struct:", port);
+ scm_uintprint (SCM_UNPACK (vtable), 16, port);
+ scm_putc (' ', port);
+ scm_write (SCM_VTABLE_LAYOUT (vtable), port);
+ scm_putc (' ', port);
+ }
scm_uintprint (SCM_UNPACK (exp), 16, port);
+ /* hackety hack */
+ if (SCM_STRUCT_APPLICABLE_P (exp))
+ {
+ if (scm_is_true (SCM_STRUCT_PROCEDURE (exp)))
+ {
+ scm_puts (" proc: ", port);
+ if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp))))
+ scm_write (SCM_STRUCT_PROCEDURE (exp), port);
+ else
+ scm_puts ("(not a procedure?)", port);
+ }
+ if (SCM_STRUCT_SETTER_P (exp))
+ {
+ scm_puts (" setter: ", port);
+ scm_write (SCM_STRUCT_SETTER (exp), port);
+ }
+ }
scm_putc ('>', port);
}
}
-void
-scm_struct_prehistory ()
-{
- scm_i_structs_to_free = SCM_EOL;
- scm_c_hook_add (&scm_before_sweep_c_hook, scm_struct_gc_init, 0, 0);
- /* With lazy sweep GC, the point at which the entire heap is swept
- is just before the mark phase. */
- scm_c_hook_add (&scm_before_mark_c_hook, scm_free_structs, 0, 0);
-}
-
void
scm_init_struct ()
{
- scm_struct_table
- = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
- required_vtable_fields = scm_from_locale_string ("prsrpw");
- scm_permanent_object (required_vtable_fields);
-
- scm_i_vtable_vtable_no_extra_fields =
- scm_permanent_object
- (scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL));
+ GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)); /* for the self data pointer */
+ GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)
+ + scm_tc3_struct); /* for the vtable data pointer */
+
+ scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
+ required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
+ required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
+ required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
+
+ scm_standard_vtable_vtable =
+ scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
+
+ scm_applicable_struct_vtable_vtable =
+ scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
+ scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
+ SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
+ SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
+ scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable);
+
+ scm_applicable_struct_with_setter_vtable_vtable =
+ scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
+ scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
+ SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,
+ SCM_VTABLE_FLAG_APPLICABLE_VTABLE | SCM_VTABLE_FLAG_SETTER_VTABLE);
+ scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable);
scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
- scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable));
scm_c_define ("vtable-index-printer",
- scm_from_int (scm_vtable_index_printer));
+ scm_from_int (scm_vtable_index_instance_printer));
scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user));
#include "libguile/struct.x"
}
-/* classes: h_files */
-
-#ifndef SCM_STRUCT_H
-#define SCM_STRUCT_H
-
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 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
- */
-
-\f
-
-#include "libguile/__scm.h"
-#include "libguile/print.h"
-
-\f
-
-/* Number of words with negative index */
-#define scm_struct_n_extra_words 4
-#define scm_struct_entity_n_extra_words 6
-
-/* These are how the initial words of a vtable are allocated. */
-#define scm_struct_i_setter -6 /* Setter */
-#define scm_struct_i_procedure -5 /* Optional procedure slot */
-#define scm_struct_i_free -4 /* Destructor */
-#define scm_struct_i_ptr -3 /* Start of block (see alloc_struct) */
-#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */
-#define scm_struct_i_size -1 /* Instance size */
-#define scm_struct_i_flags -1 /* Upper 12 bits used as flags */
-
-/* These indices must correspond to required_vtable_fields in
- struct.c. */
-#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */
-#define scm_vtable_index_vtable 1 /* A pointer to the handle for this vtable. */
-#define scm_vtable_index_printer 2 /* A printer for this struct type. */
-#define scm_vtable_offset_user 3 /* Where do user fields start? */
-
-typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
-
-#define SCM_STRUCTF_MASK (0xFFF << 20)
-#define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
-#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
- (no hidden words) */
-
-#define SCM_STRUCTP(X) (!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
-#define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X))
-#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_struct))
-
-#define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout]))
-#define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v))
-
-#define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable]))
-#define SCM_STRUCT_VTABLE_FLAGS(X) \
- (SCM_STRUCT_VTABLE_DATA (X) [scm_struct_i_flags])
-#define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer]))
-#define SCM_SET_STRUCT_PRINTER(x, v)\
- (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = SCM_UNPACK (v))
-#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_t_bits) (D))
-/* Efficiency is important in the following macro, since it's used in GC */
-#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
-
-#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
-#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
-#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
-#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
-SCM_API SCM scm_struct_table;
-
-#define SCM_STRUCT_GC_CHAIN(X) SCM_CELL_OBJECT_3 (X)
-#define SCM_SET_STRUCT_GC_CHAIN(X, Y) SCM_SET_CELL_OBJECT_3 (X, Y)
-
-/* For clearing structs. We can't use the regular GC mark bits, as
- meddling with them at random times would mess up the invariants of
- the garbage collector.
- */
-#define SCM_STRUCT_MARK_P(X) SCM_CELL_WORD_2 (X)
-#define SCM_SET_STRUCT_MARK(X) SCM_SET_CELL_WORD_2 (X, 0x1)
-#define SCM_CLEAR_STRUCT_MARK(X) SCM_SET_CELL_WORD_2 (X, 0x0)
-
-SCM_INTERNAL SCM scm_i_structs_to_free;
-
-\f
-
-SCM_API scm_t_bits * scm_alloc_struct (int n_words, int n_extra,
- const char *what);
-SCM_API void scm_struct_free_0 (scm_t_bits * vtable, scm_t_bits * data);
-SCM_API void scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data);
-SCM_API void scm_struct_free_standard (scm_t_bits * vtable, scm_t_bits * data);
-SCM_API void scm_struct_free_entity (scm_t_bits * vtable, scm_t_bits * data);
-SCM_API SCM scm_make_struct_layout (SCM fields);
-SCM_API SCM scm_struct_p (SCM x);
-SCM_API SCM scm_struct_vtable_p (SCM x);
-SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
-SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
-SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
-SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
-SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
-SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
-SCM_API SCM scm_struct_vtable (SCM handle);
-SCM_API SCM scm_struct_vtable_tag (SCM handle);
-SCM_API unsigned long scm_struct_ihashq (SCM obj, unsigned long n);
-SCM_API SCM scm_struct_create_handle (SCM obj);
-SCM_API SCM scm_struct_vtable_name (SCM vtable);
-SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
-SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
-SCM_API void scm_struct_prehistory (void);
-SCM_INTERNAL void scm_init_struct (void);
-
-#endif /* SCM_STRUCT_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* classes: h_files */
+
+#ifndef SCM_STRUCT_H
+#define SCM_STRUCT_H
+
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+\f
+
+/* The relationship between a struct and its vtable is a bit complicated,
+ because we want structs to be used as GOOPS' native representation -- which
+ in turn means we need support for changing the "class" (vtable) of an
+ "instance" (struct). This necessitates some indirection and trickery.
+
+ I would like to write this all up here, but for now:
+
+ http://wingolog.org/archives/2009/11/09/class-redefinition-in-guile
+ */
+
+/* All vtables have the following fields. */
+#define SCM_VTABLE_BASE_LAYOUT \
+ "pr" /* layout */ \
+ "uh" /* flags */ \
+ "sr" /* self */ \
+ "uh" /* finalizer */ \
+ "pw" /* printer */ \
+ "ph" /* name (hidden from make-struct for back-compat reasons) */ \
+ "uh" /* reserved */ \
+ "uh" /* reserved */
+
+#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */
+#define scm_vtable_index_flags 1 /* Class flags */
+#define scm_vtable_index_self 2 /* A pointer to the vtable itself */
+#define scm_vtable_index_instance_finalize 3 /* Finalizer for instances of this struct type. */
+#define scm_vtable_index_instance_printer 4 /* A printer for this struct type. */
+#define scm_vtable_index_name 5 /* Name of this vtable. */
+#define scm_vtable_index_reserved_6 6
+#define scm_vtable_index_reserved_7 7
+#define scm_vtable_offset_user 8 /* Where do user fields start in the vtable? */
+
+/* All applicable structs have the following fields. */
+#define SCM_APPLICABLE_BASE_LAYOUT \
+ "pw" /* procedure */
+#define SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT \
+ "pw" /* procedure */ \
+ "pw" /* setter */
+#define scm_applicable_struct_index_procedure 0 /* The procedure of an applicable
+ struct. Only valid if the
+ struct's vtable has the
+ applicable flag set. */
+#define scm_applicable_struct_index_setter 1 /* The setter of an applicable
+ struct. Only valid if the
+ struct's vtable has the
+ setter flag set. */
+
+#define SCM_VTABLE_FLAG_VTABLE (1L << 0) /* instances of this vtable are themselves vtables? */
+#define SCM_VTABLE_FLAG_APPLICABLE_VTABLE (1L << 1) /* instances of this vtable are applicable vtables? */
+#define SCM_VTABLE_FLAG_APPLICABLE (1L << 2) /* instances of this vtable are applicable? */
+#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 3) /* instances of this vtable are applicable-with-setter vtables? */
+#define SCM_VTABLE_FLAG_SETTER (1L << 4) /* instances of this vtable are applicable-with-setters? */
+#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 5)
+#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 6)
+#define SCM_VTABLE_FLAG_SMOB_0 (1L << 7)
+#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 8)
+#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 9)
+#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 10)
+#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 11)
+#define SCM_VTABLE_FLAG_GOOPS_4 (1L << 12)
+#define SCM_VTABLE_FLAG_GOOPS_5 (1L << 13)
+#define SCM_VTABLE_FLAG_GOOPS_6 (1L << 14)
+#define SCM_VTABLE_FLAG_GOOPS_7 (1L << 15)
+#define SCM_VTABLE_USER_FLAG_SHIFT 16
+
+typedef void (*scm_t_struct_finalize) (SCM obj);
+
+#define SCM_STRUCTP(X) (!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
+#define SCM_STRUCT_SLOTS(X) ((SCM*)SCM_CELL_WORD_1 ((X)))
+#define SCM_STRUCT_SLOT_REF(X,I) (SCM_STRUCT_SLOTS (X)[(I)])
+#define SCM_STRUCT_SLOT_SET(X,I,V) SCM_STRUCT_SLOTS (X)[(I)]=(V)
+#define SCM_STRUCT_DATA(X) ((scm_t_bits*)SCM_CELL_WORD_1 (X))
+#define SCM_STRUCT_DATA_REF(X,I) (SCM_STRUCT_DATA (X)[(I)])
+#define SCM_STRUCT_DATA_SET(X,I,V) SCM_STRUCT_DATA (X)[(I)]=(V)
+
+/* The SCM_VTABLE_* macros assume that you're passing them a struct which is a
+ valid vtable. */
+#define SCM_VTABLE_LAYOUT(X) (SCM_STRUCT_SLOT_REF ((X), scm_vtable_index_layout))
+#define SCM_SET_VTABLE_LAYOUT(X,L) (SCM_STRUCT_SLOT_SET ((X), scm_vtable_index_layout, L))
+#define SCM_VTABLE_FLAGS(X) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags))
+#define SCM_SET_VTABLE_FLAGS(X,F) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) |= (F))
+#define SCM_CLEAR_VTABLE_FLAGS(X,F) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) &= (~(F)))
+#define SCM_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) & (F))
+#define SCM_VTABLE_INSTANCE_FINALIZER(X) ((scm_t_struct_finalize)SCM_STRUCT_DATA_REF (X, scm_vtable_index_instance_finalize))
+#define SCM_SET_VTABLE_INSTANCE_FINALIZER(X,P) (SCM_STRUCT_DATA_SET (X, scm_vtable_index_instance_finalize, (scm_t_bits)(P)))
+#define SCM_VTABLE_INSTANCE_PRINTER(X) (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_instance_printer))
+#define SCM_SET_VTABLE_INSTANCE_PRINTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_instance_printer, (P)))
+#define SCM_VTABLE_NAME(X) (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_name))
+#define SCM_SET_VTABLE_NAME(X,V) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_name, V))
+
+/* Structs hold a pointer to their vtable's data, not the vtable itself. To get
+ the vtable we have to do an indirection through the self slot. */
+#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits*)(SCM_CELL_WORD_0 (X) - scm_tc3_struct))
+#define SCM_STRUCT_VTABLE_SLOTS(X) ((SCM*)(SCM_CELL_WORD_0 (X) - scm_tc3_struct))
+#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_SLOTS(X)[scm_vtable_index_self])
+/* But often we just need to access the vtable's data; we can do that without
+ the data->self->data indirection. */
+#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_SLOTS (X)[scm_vtable_index_layout])
+#define SCM_STRUCT_PRINTER(X) (SCM_STRUCT_VTABLE_SLOTS (X)[scm_vtable_index_instance_printer])
+#define SCM_STRUCT_FINALIZER(X) ((scm_t_struct_finalize)SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_instance_finalize])
+#define SCM_STRUCT_VTABLE_FLAGS(X) (SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_flags])
+#define SCM_STRUCT_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_flags]&(F))
+
+#define SCM_STRUCT_APPLICABLE_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_APPLICABLE))
+#define SCM_STRUCT_SETTER_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_SETTER))
+#define SCM_STRUCT_PROCEDURE(X) (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_procedure))
+#define SCM_SET_STRUCT_PROCEDURE(X,P) (SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_procedure, P))
+#define SCM_STRUCT_SETTER(X) (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_setter))
+#define SCM_SET_STRUCT_SETTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_setter, P))
+
+#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
+#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
+#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
+#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
+SCM_API SCM scm_struct_table;
+
+SCM_API SCM scm_standard_vtable_vtable;
+SCM_API SCM scm_applicable_struct_vtable_vtable;
+SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable;
+
+\f
+
+SCM_API SCM scm_make_struct_layout (SCM fields);
+SCM_API SCM scm_struct_p (SCM x);
+SCM_API SCM scm_struct_vtable_p (SCM x);
+SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
+SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
+ scm_t_bits init, ...);
+SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
+ scm_t_bits init[]);
+SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
+SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
+SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
+SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
+SCM_API SCM scm_struct_vtable (SCM handle);
+SCM_API SCM scm_struct_vtable_tag (SCM handle);
+SCM_API SCM scm_struct_create_handle (SCM obj);
+SCM_API SCM scm_struct_vtable_name (SCM vtable);
+SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
+SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
+
+SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
+SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
+SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words);
+SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
+SCM_INTERNAL void scm_init_struct (void);
+
+#endif /* SCM_STRUCT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
lookup_interned_symbol (SCM name, unsigned long raw_hash)
{
/* Try to find the symbol in the symbols table */
- SCM l;
- size_t len = scm_i_string_length (name);
+ SCM result = SCM_BOOL_F;
+ SCM bucket, elt, previous_elt;
+ size_t len;
unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
- for (l = SCM_HASHTABLE_BUCKET (symbols, hash);
- !scm_is_null (l);
- l = SCM_CDR (l))
+ len = scm_i_string_length (name);
+ bucket = SCM_HASHTABLE_BUCKET (symbols, hash);
+
+ for (elt = bucket, previous_elt = SCM_BOOL_F;
+ !scm_is_null (elt);
+ previous_elt = elt, elt = SCM_CDR (elt))
{
- SCM sym = SCM_CAAR (l);
+ SCM pair, sym;
+
+ pair = SCM_CAR (elt);
+ if (!scm_is_pair (pair))
+ abort ();
+
+ if (SCM_WEAK_PAIR_CAR_DELETED_P (pair))
+ {
+ /* PAIR is a weak pair whose key got nullified: remove it from
+ BUCKET. */
+ /* FIXME: Since this is done lazily, i.e., only when a new symbol
+ is to be inserted in a bucket containing deleted symbols, the
+ number of items in the hash table may remain erroneous for some
+ time, thus precluding proper rehashing. */
+ if (previous_elt != SCM_BOOL_F)
+ SCM_SETCDR (previous_elt, SCM_CDR (elt));
+ else
+ bucket = SCM_CDR (elt);
+
+ SCM_HASHTABLE_DECREMENT (symbols);
+ continue;
+ }
+
+ sym = SCM_CAR (pair);
+
if (scm_i_symbol_hash (sym) == raw_hash
&& scm_i_symbol_length (sym) == len)
{
}
}
- return sym;
+ /* We found it. */
+ result = sym;
+ break;
}
next_symbol:
;
}
- return SCM_BOOL_F;
+ if (SCM_HASHTABLE_N_ITEMS (symbols) < SCM_HASHTABLE_LOWER (symbols))
+ /* We removed many symbols in this pass so trigger a rehashing. */
+ scm_i_rehash (symbols, scm_i_hash_symbol, 0, "lookup_interned_symbol");
+
+ return result;
}
/* Intern SYMBOL, an uninterned symbol. */
scm_symbols_prehistory ()
{
symbols = scm_make_weak_key_hash_table (scm_from_int (2139));
- scm_permanent_object (symbols);
}
/* picks up scmconfig.h too */
#include "libguile/__scm.h"
-#if HAVE_INTTYPES_H
-# include <inttypes.h> /* for INTPTR_MAX and friends */
-#else
-# if HAVE_STDINT_H
-# include <stdint.h> /* for INTPTR_MAX and friends */
-# endif
-#endif
-
\f
/* In the beginning was the Word:
/* For dealing with the bit level representation of scheme objects we define
* scm_t_bits:
*/
-/* On Solaris 7 and 8, /usr/include/sys/int_limits.h defines
- INTPTR_MAX and UINTPTR_MAX to empty, INTPTR_MIN is not defined.
- To avoid uintptr_t and intptr_t in this case we require
- UINTPTR_MAX-0 != 0 etc. */
-#if SCM_SIZEOF_INTPTR_T != 0 && defined(INTPTR_MAX) && defined(INTPTR_MIN) \
- && INTPTR_MAX-0 != 0 && INTPTR_MIN-0 != 0 \
- && SCM_SIZEOF_UINTPTR_T != 0 && defined(UINTPTR_MAX) && UINTPTR_MAX-0 != 0
-
-typedef intptr_t scm_t_signed_bits;
-#define SCM_T_SIGNED_BITS_MAX INTPTR_MAX
-#define SCM_T_SIGNED_BITS_MIN INTPTR_MIN
-typedef uintptr_t scm_t_bits;
-#define SIZEOF_SCM_T_BITS SCM_SIZEOF_UINTPTR_T
-#define SCM_T_BITS_MAX UINTPTR_MAX
-#else
+typedef scm_t_intptr scm_t_signed_bits;
+typedef scm_t_uintptr scm_t_bits;
-typedef signed long scm_t_signed_bits;
-#define SCM_T_SIGNED_BITS_MAX LONG_MAX
-#define SCM_T_SIGNED_BITS_MIN LONG_MIN
-typedef unsigned long scm_t_bits;
-#define SIZEOF_SCM_T_BITS SCM_SIZEOF_UNSIGNED_LONG
-#define SCM_T_BITS_MAX ULONG_MAX
+#define SCM_T_SIGNED_BITS_MAX SCM_T_INTPTR_MAX
+#define SCM_T_SIGNED_BITS_MIN SCM_T_INTPTR_MIN
+#define SCM_T_BITS_MAX SCM_T_UINTPTR_MAX
-#endif
/* But as external interface, we define SCM, which may, according to the
* desired level of type checking, be defined in several ways:
/* This is the default, which provides an intermediate level of compile time
* type checking while still resulting in very efficient code.
*/
- typedef struct scm_unused_struct * SCM;
+ typedef struct scm_unused_struct { char scm_unused_field; } *SCM;
/*
The 0?: constructions makes sure that the code is never executed,
* tc8 (for objects with tc3==100):
* 00000-100: special objects ('flags')
* 00001-100: characters
- * 00010-100: evaluator byte codes ('isyms')
- * 00011-100: evaluator byte codes ('ilocs')
+ * 00010-100: unused
+ * 00011-100: unused
*
*
* Summary of type codes on the heap
* tc16 (for tc7==scm_tc7_smob):
* The largest part of the space of smob types is not subdivided in a
* predefined way, since smobs can be added arbitrarily by user C code.
- * However, while Guile also defines a number of smob types throughout,
- * there is one smob type, namely scm_tc_free_cell, for which Guile assumes
- * that it is declared first and thus gets a known-in-advance tc16-code.
- * The reason of requiring a fixed tc16-code for this type is performance.
*/
\f
#define scm_tc3_cons 0
#define scm_tc3_struct 1
#define scm_tc3_int_1 (scm_tc2_int + 0)
-#define scm_tc3_closure 3
+#define scm_tc3_unused 3
#define scm_tc3_imm24 4
#define scm_tc3_tc7_1 5
#define scm_tc3_int_2 (scm_tc2_int + 4)
#define scm_tc7_string 21
#define scm_tc7_number 23
#define scm_tc7_stringbuf 39
+#define scm_tc7_bytevector 77
-/* Many of the following should be turned
- * into structs or smobs. We need back some
- * of these 7 bit tags! */
+#define scm_tc7_unused_1 31
+#define scm_tc7_hashtable 29
+#define scm_tc7_fluid 37
+#define scm_tc7_dynamic_state 45
-#define scm_tc7_pws 31
-
-#define scm_tc7_unused_1 29
-#define scm_tc7_unused_2 37
-#define scm_tc7_unused_3 45
#define scm_tc7_unused_4 47
#define scm_tc7_unused_5 53
#define scm_tc7_unused_6 55
#define scm_tc7_unused_7 71
-#define scm_tc7_unused_8 77
-#define scm_tc7_dsubr 61
+#define scm_tc7_unused_17 61
#define scm_tc7_gsubr 63
-#define scm_tc7_rpsubr 69
+#define scm_tc7_unused_19 69
#define scm_tc7_program 79
-#define scm_tc7_subr_0 85
-#define scm_tc7_subr_1 87
-#define scm_tc7_cxr 93
-#define scm_tc7_subr_3 95
-#define scm_tc7_subr_2 101
-#define scm_tc7_asubr 103
-#define scm_tc7_subr_1o 109
-#define scm_tc7_subr_2o 111
-#define scm_tc7_lsubr_2 117
-#define scm_tc7_lsubr 119
+#define scm_tc7_unused_9 85
+#define scm_tc7_unused_10 87
+#define scm_tc7_unused_20 93
+#define scm_tc7_unused_11 95
+#define scm_tc7_unused_12 101
+#define scm_tc7_unused_18 103
+#define scm_tc7_unused_13 109
+#define scm_tc7_unused_14 111
+#define scm_tc7_unused_15 117
+#define scm_tc7_unused_16 119
/* There are 256 port subtypes. */
#define scm_tc7_port 125
#define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag))
-/* Here is the first smob subtype. */
-
-/* scm_tc_free_cell is the 0th smob type. We place this in free cells to tell
- * the conservative marker not to trace it. */
-#define scm_tc_free_cell (scm_tc7_smob + 0 * 256L)
-
\f
/* {Immediate Values}
{
scm_tc8_flag = scm_tc3_imm24 + 0x00, /* special objects ('flags') */
scm_tc8_char = scm_tc3_imm24 + 0x08, /* characters */
- scm_tc8_isym = scm_tc3_imm24 + 0x10, /* evaluator byte codes ('isyms') */
- scm_tc8_iloc = scm_tc3_imm24 + 0x18 /* evaluator byte codes ('ilocs') */
+ scm_tc8_unused_0 = scm_tc3_imm24 + 0x10,
+ scm_tc8_unused_1 = scm_tc3_imm24 + 0x18
};
#define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff)
#define SCM_MAKIFLAG(n) SCM_MAKE_ITAG8 ((n), scm_tc8_flag)
#define SCM_IFLAGNUM(n) (SCM_ITAG8_DATA (n))
+/*
+ * IMPORTANT NOTE regarding IFLAG numbering!!!
+ *
+ * Several macros depend upon careful IFLAG numbering of SCM_BOOL_F,
+ * SCM_BOOL_T, SCM_ELISP_NIL, SCM_EOL, and the two SCM_XXX_*_DONT_USE
+ * constants. In particular:
+ *
+ * - SCM_BOOL_F and SCM_BOOL_T must differ in exactly one bit position.
+ * (used to implement scm_is_bool_and_not_nil, aka scm_is_bool)
+ *
+ * - SCM_ELISP_NIL and SCM_BOOL_F must differ in exactly one bit position.
+ * (used to implement scm_is_false_or_nil and
+ * scm_is_true_and_not_nil)
+ *
+ * - SCM_ELISP_NIL and SCM_EOL must differ in exactly one bit position.
+ * (used to implement scm_is_null_or_nil)
+ *
+ * - SCM_ELISP_NIL, SCM_BOOL_F, SCM_EOL, SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE
+ * must all be equal except for two bit positions.
+ * (used to implement scm_is_lisp_false)
+ *
+ * - SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, SCM_XXX_ANOTHER_BOOLEAN_DONT_USE
+ * must all be equal except for two bit positions.
+ * (used to implement scm_is_bool_or_nil)
+ *
+ * These properties allow the aforementioned macros to be implemented
+ * by bitwise ANDing with a mask and then comparing with a constant,
+ * using as a common basis the macro SCM_MATCHES_BITS_IN_COMMON,
+ * defined below. The properties are checked at compile-time using
+ * `verify' macros near the top of boolean.c and pairs.c.
+ */
#define SCM_BOOL_F SCM_MAKIFLAG (0)
-#define SCM_BOOL_T SCM_MAKIFLAG (1)
-#define SCM_UNDEFINED SCM_MAKIFLAG (2)
-#define SCM_EOF_VAL SCM_MAKIFLAG (3)
-#define SCM_EOL SCM_MAKIFLAG (4)
-#define SCM_UNSPECIFIED SCM_MAKIFLAG (5)
+#define SCM_ELISP_NIL SCM_MAKIFLAG (1)
+
+#ifdef BUILDING_LIBGUILE
+#define SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE SCM_MAKIFLAG (2)
+#endif
+
+#define SCM_EOL SCM_MAKIFLAG (3)
+#define SCM_BOOL_T SCM_MAKIFLAG (4)
+
+#ifdef BUILDING_LIBGUILE
+#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE SCM_MAKIFLAG (5)
+#endif
+
+#define SCM_UNSPECIFIED SCM_MAKIFLAG (6)
+#define SCM_UNDEFINED SCM_MAKIFLAG (7)
+#define SCM_EOF_VAL SCM_MAKIFLAG (8)
/* When a variable is unbound this is marked by the SCM_UNDEFINED
* value. The following is an unbound value which can be handled on
* the code which handles this value in C so that SCM_UNDEFINED can be
* used instead. It is not ideal to let this kind of unique and
* strange values loose on the Scheme level. */
-#define SCM_UNBOUND SCM_MAKIFLAG (6)
-
-/* The Elisp nil value. */
-#define SCM_ELISP_NIL SCM_MAKIFLAG (7)
-
+#define SCM_UNBOUND SCM_MAKIFLAG (9)
#define SCM_UNBNDP(x) (scm_is_eq ((x), SCM_UNDEFINED))
-\f
-
-/* Evaluator byte codes ('immediate symbols'). These constants are used only
- * in eval but their values have to be allocated here. The indices of the
- * SCM_IM_ symbols must agree with the declarations in print.c:
- * scm_isymnames. */
-
-#define SCM_ISYMP(n) (SCM_ITAG8 (n) == scm_tc8_isym)
-#define SCM_MAKISYM(n) SCM_MAKE_ITAG8 ((n), scm_tc8_isym)
-
-#define SCM_IM_AND SCM_MAKISYM (0)
-#define SCM_IM_BEGIN SCM_MAKISYM (1)
-#define SCM_IM_CASE SCM_MAKISYM (2)
-#define SCM_IM_COND SCM_MAKISYM (3)
-#define SCM_IM_DO SCM_MAKISYM (4)
-#define SCM_IM_IF SCM_MAKISYM (5)
-#define SCM_IM_LAMBDA SCM_MAKISYM (6)
-#define SCM_IM_LET SCM_MAKISYM (7)
-#define SCM_IM_LETSTAR SCM_MAKISYM (8)
-#define SCM_IM_LETREC SCM_MAKISYM (9)
-#define SCM_IM_OR SCM_MAKISYM (10)
-#define SCM_IM_QUOTE SCM_MAKISYM (11)
-#define SCM_IM_SET_X SCM_MAKISYM (12)
-#define SCM_IM_DEFINE SCM_MAKISYM (13)
-#define SCM_IM_APPLY SCM_MAKISYM (14)
-#define SCM_IM_CONT SCM_MAKISYM (15)
-#define SCM_IM_DISPATCH SCM_MAKISYM (16)
-#define SCM_IM_SLOT_REF SCM_MAKISYM (17)
-#define SCM_IM_SLOT_SET_X SCM_MAKISYM (18)
-#define SCM_IM_DELAY SCM_MAKISYM (19)
-#define SCM_IM_FUTURE SCM_MAKISYM (20)
-#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (21)
-#define SCM_IM_ELSE SCM_MAKISYM (22)
-#define SCM_IM_ARROW SCM_MAKISYM (23)
-#define SCM_IM_NIL_COND SCM_MAKISYM (24) /* Multi-language support */
-#define SCM_IM_BIND SCM_MAKISYM (25) /* Multi-language support */
+/*
+ * SCM_MATCHES_BITS_IN_COMMON(x,a,b) returns 1 if and only if x
+ * matches both a and b in every bit position where a and b are equal;
+ * otherwise it returns 0. Bit positions where a and b differ are
+ * ignored.
+ *
+ * This is used to efficiently compare against two values which differ
+ * in exactly one bit position, or against four values which differ in
+ * exactly two bit positions. It is the basis for the following
+ * macros:
+ *
+ * scm_is_null_or_nil,
+ * scm_is_false_or_nil,
+ * scm_is_true_and_not_nil,
+ * scm_is_lisp_false,
+ * scm_is_lisp_true,
+ * scm_is_bool_and_not_nil (aka scm_is_bool)
+ * scm_is_bool_or_nil.
+ */
+#define SCM_MATCHES_BITS_IN_COMMON(x,a,b) \
+ ((SCM_UNPACK(x) & ~(SCM_UNPACK(a) ^ SCM_UNPACK(b))) == \
+ (SCM_UNPACK(a) & SCM_UNPACK(b)))
+/*
+ * These macros are used for compile-time verification that the
+ * constants have the properties needed for the above macro to work
+ * properly.
+ */
+#ifdef BUILDING_LIBGUILE
+#define SCM_WITH_LEAST_SIGNIFICANT_1_BIT_CLEARED(x) ((x) & ((x)-1))
+#define SCM_HAS_EXACTLY_ONE_BIT_SET(x) \
+ ((x) != 0 && SCM_WITH_LEAST_SIGNIFICANT_1_BIT_CLEARED (x) == 0)
+#define SCM_HAS_EXACTLY_TWO_BITS_SET(x) \
+ (SCM_HAS_EXACTLY_ONE_BIT_SET (SCM_WITH_LEAST_SIGNIFICANT_1_BIT_CLEARED (x)))
+
+#define SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION(a,b) \
+ (SCM_HAS_EXACTLY_ONE_BIT_SET (SCM_UNPACK(a) ^ SCM_UNPACK(b)))
+#define SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS(a,b,c,d) \
+ (SCM_HAS_EXACTLY_TWO_BITS_SET ((SCM_UNPACK(a) ^ SCM_UNPACK(b)) | \
+ (SCM_UNPACK(b) ^ SCM_UNPACK(c)) | \
+ (SCM_UNPACK(c) ^ SCM_UNPACK(d))))
+#endif /* BUILDING_LIBGUILE */
\f
/* Dispatching aids:
case scm_tc3_struct + 112:\
case scm_tc3_struct + 120
-/* For closures
- */
-#define scm_tcs_closures \
- scm_tc3_closure + 0:\
- case scm_tc3_closure + 8:\
- case scm_tc3_closure + 16:\
- case scm_tc3_closure + 24:\
- case scm_tc3_closure + 32:\
- case scm_tc3_closure + 40:\
- case scm_tc3_closure + 48:\
- case scm_tc3_closure + 56:\
- case scm_tc3_closure + 64:\
- case scm_tc3_closure + 72:\
- case scm_tc3_closure + 80:\
- case scm_tc3_closure + 88:\
- case scm_tc3_closure + 96:\
- case scm_tc3_closure + 104:\
- case scm_tc3_closure + 112:\
- case scm_tc3_closure + 120
-
/* For subrs
*/
#define scm_tcs_subrs \
- scm_tc7_asubr:\
- case scm_tc7_subr_0:\
- case scm_tc7_subr_1:\
- case scm_tc7_dsubr:\
- case scm_tc7_cxr:\
- case scm_tc7_subr_3:\
- case scm_tc7_subr_2:\
- case scm_tc7_rpsubr:\
- case scm_tc7_subr_1o:\
- case scm_tc7_subr_2o:\
- case scm_tc7_lsubr_2:\
- case scm_tc7_lsubr: \
case scm_tc7_gsubr
\f
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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
# include <config.h>
#endif
+#include "libguile/bdw-gc.h"
#include "libguile/_scm.h"
#if HAVE_UNISTD_H
#include "libguile/init.h"
#include "libguile/scmsigs.h"
#include "libguile/strings.h"
+#include "libguile/weaks.h"
#ifdef __MINGW32__
#ifndef ETIMEDOUT
}
}
+\f
/*** Queues */
+/* Note: We annotate with "GC-robust" assignments whose purpose is to avoid
+ the risk of false references leading to unbounded retained space as
+ described in "Bounding Space Usage of Conservative Garbage Collectors",
+ H.J. Boehm, 2001. */
+
/* Make an empty queue data structure.
*/
static SCM
if (scm_is_eq (c, SCM_CAR (q)))
SCM_SETCAR (q, SCM_CDR (c));
SCM_SETCDR (prev, SCM_CDR (c));
+
+ /* GC-robust */
+ SCM_SETCDR (c, SCM_EOL);
+
SCM_CRITICAL_SECTION_END;
return 1;
}
if (scm_is_null (SCM_CDR (q)))
SCM_SETCAR (q, SCM_EOL);
SCM_CRITICAL_SECTION_END;
+
+ /* GC-robust */
+ SCM_SETCDR (c, SCM_EOL);
+
return SCM_CAR (c);
}
}
/*** Thread smob routines */
-static SCM
-thread_mark (SCM obj)
-{
- scm_i_thread *t = SCM_I_THREAD_DATA (obj);
- scm_gc_mark (t->result);
- scm_gc_mark (t->cleanup_handler);
- scm_gc_mark (t->join_queue);
- scm_gc_mark (t->mutexes);
- scm_gc_mark (t->dynwinds);
- scm_gc_mark (t->active_asyncs);
- scm_gc_mark (t->continuation_root);
- scm_gc_mark (t->vm);
- return t->dynamic_state;
-}
static int
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
return 1;
}
-static size_t
-thread_free (SCM obj)
-{
- scm_i_thread *t = SCM_I_THREAD_DATA (obj);
- assert (t->exited);
- scm_gc_free (t, sizeof (*t), "thread");
- return 0;
-}
-
+\f
/*** Blocking on queues. */
/* See also scm_i_queue_async_cell for how such a block is
return thread;
}
+\f
/* Getting into and out of guile mode.
*/
-/* Ken Raeburn observes that the implementation of suspend and resume
- (and the things that build on top of them) are very likely not
- correct (see below). We will need fix this eventually, and that's
- why scm_leave_guile/scm_enter_guile are not exported in the API.
-
- Ken writes:
-
- Consider this sequence:
-
- Function foo, called in Guile mode, calls suspend (maybe indirectly
- through scm_leave_guile), which does this:
-
- // record top of stack for the GC
- t->top = SCM_STACK_PTR (&t); // just takes address of automatic
- var 't'
- // save registers.
- SCM_FLUSH_REGISTER_WINDOWS; // sparc only
- SCM_I_SETJMP (t->regs); // here's most of the magic
-
- ... and returns.
-
- Function foo has a SCM value X, a handle on a non-immediate object, in
- a caller-saved register R, and it's the only reference to the object
- currently.
-
- The compiler wants to use R in suspend, so it pushes the current
- value, X, into a stack slot which will be reloaded on exit from
- suspend; then it loads stuff into R and goes about its business. The
- setjmp call saves (some of) the current registers, including R, which
- no longer contains X. (This isn't a problem for a normal
- setjmp/longjmp situation, where longjmp would be called before
- setjmp's caller returns; the old value for X would be loaded back from
- the stack after the longjmp, before the function returned.)
-
- So, suspend returns, loading X back into R (and invalidating the jump
- buffer) in the process. The caller foo then goes off and calls a
- bunch of other functions out of Guile mode, occasionally storing X on
- the stack again, but, say, much deeper on the stack than suspend's
- stack frame went, and the stack slot where suspend had written X has
- long since been overwritten with other values.
-
- Okay, nothing actively broken so far. Now, let garbage collection
- run, triggered by another thread.
-
- The thread calling foo is out of Guile mode at the time, so the
- garbage collector just scans a range of stack addresses. Too bad that
- X isn't stored there. So the pointed-to storage goes onto the free
- list, and I think you can see where things go from there.
-
- Is there anything I'm missing that'll prevent this scenario from
- happening? I mean, aside from, "well, suspend and scm_leave_guile
- don't have many local variables, so they probably won't need to save
- any registers on most systems, so we hope everything will wind up in
- the jump buffer and we'll just get away with it"?
-
- (And, going the other direction, if scm_leave_guile and suspend push
- the stack pointer over onto a new page, and foo doesn't make further
- function calls and thus the stack pointer no longer includes that
- page, are we guaranteed that the kernel cannot release the now-unused
- stack page that contains the top-of-stack pointer we just saved? I
- don't know if any OS actually does that. If it does, we could get
- faults in garbage collection.)
-
- I don't think scm_without_guile has to have this problem, as it gets
- more control over the stack handling -- but it should call setjmp
- itself. I'd probably try something like:
-
- // record top of stack for the GC
- t->top = SCM_STACK_PTR (&t);
- // save registers.
- SCM_FLUSH_REGISTER_WINDOWS;
- SCM_I_SETJMP (t->regs);
- res = func(data);
- scm_enter_guile (t);
-
- ... though even that's making some assumptions about the stack
- ordering of local variables versus caller-saved registers.
-
- For something like scm_leave_guile to work, I don't think it can just
- rely on invalidated jump buffers. A valid jump buffer, and a handle
- on the stack state at the point when the jump buffer was initialized,
- together, would work fine, but I think then we're talking about macros
- invoking setjmp in the caller's stack frame, and requiring that the
- caller of scm_leave_guile also call scm_enter_guile before returning,
- kind of like pthread_cleanup_push/pop calls that have to be paired up
- in a function. (In fact, the pthread ones have to be paired up
- syntactically, as if they might expand to a compound statement
- incorporating the user's code, and invoking a compiler's
- exception-handling primitives. Which might be something to think
- about for cases where Guile is used with C++ exceptions or
- pthread_cancel.)
-*/
+#ifdef SCM_HAVE_THREAD_STORAGE_CLASS
-scm_i_pthread_key_t scm_i_thread_key;
+/* When thread-local storage (TLS) is available, a pointer to the
+ current-thread object is kept in TLS. Note that storing the thread-object
+ itself in TLS (rather than a pointer to some malloc'd memory) is not
+ possible since thread objects may live longer than the actual thread they
+ represent. */
+SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread = NULL;
-static void
-resume (scm_i_thread *t)
-{
- t->top = NULL;
- if (t->clear_freelists_p)
- {
- *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
- *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
- t->clear_freelists_p = 0;
- }
-}
+# define SET_CURRENT_THREAD(_t) scm_i_current_thread = (_t)
-typedef void* scm_t_guile_ticket;
+#else /* !SCM_HAVE_THREAD_STORAGE_CLASS */
-static void
-scm_enter_guile (scm_t_guile_ticket ticket)
-{
- scm_i_thread *t = (scm_i_thread *)ticket;
- if (t)
- {
- scm_i_pthread_mutex_lock (&t->heap_mutex);
- t->heap_mutex_locked_by_self = 1;
- resume (t);
- }
-}
+/* Key used to retrieve the current thread with `pthread_getspecific ()'. */
+scm_i_pthread_key_t scm_i_thread_key;
-static scm_i_thread *
-suspend (void)
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
+# define SET_CURRENT_THREAD(_t) \
+ scm_i_pthread_setspecific (scm_i_thread_key, (_t))
- /* record top of stack for the GC */
- t->top = SCM_STACK_PTR (&t);
- /* save registers. */
- SCM_FLUSH_REGISTER_WINDOWS;
- SCM_I_SETJMP (t->regs);
- return t;
-}
+#endif /* !SCM_HAVE_THREAD_STORAGE_CLASS */
-static scm_t_guile_ticket
-scm_leave_guile ()
-{
- scm_i_thread *t = suspend ();
- if (t->heap_mutex_locked_by_self)
- {
- t->heap_mutex_locked_by_self = 0;
- scm_i_pthread_mutex_unlock (&t->heap_mutex);
- }
- return (scm_t_guile_ticket) t;
-}
static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static scm_i_thread *all_threads = NULL;
static void
guilify_self_1 (SCM_STACKITEM *base)
{
- scm_i_thread *t = malloc (sizeof (scm_i_thread));
+ scm_i_thread *t = scm_gc_malloc (sizeof (scm_i_thread), "thread");
t->pthread = scm_i_pthread_self ();
t->handle = SCM_BOOL_F;
t->active_asyncs = SCM_EOL;
t->block_asyncs = 1;
t->pending_asyncs = 1;
- t->last_debug_frame = NULL;
+ t->critical_section_level = 0;
t->base = base;
#ifdef __ia64__
/* Calculate and store off the base of this thread's register
currently have type `void'. */
abort ();
- scm_i_pthread_mutex_init (&t->heap_mutex, NULL);
- t->heap_mutex_locked_by_self = 0;
scm_i_pthread_mutex_init (&t->admin_mutex, NULL);
- t->clear_freelists_p = 0;
- t->gc_running_p = 0;
+ t->current_mark_stack_ptr = NULL;
+ t->current_mark_stack_limit = NULL;
t->canceled = 0;
t->exited = 0;
+ t->guile_mode = 0;
- t->freelist = SCM_EOL;
- t->freelist2 = SCM_EOL;
- SCM_SET_FREELIST_LOC (scm_i_freelist, &t->freelist);
- SCM_SET_FREELIST_LOC (scm_i_freelist2, &t->freelist2);
-
- scm_i_pthread_setspecific (scm_i_thread_key, t);
-
- scm_i_pthread_mutex_lock (&t->heap_mutex);
- t->heap_mutex_locked_by_self = 1;
+ SET_CURRENT_THREAD (t);
scm_i_pthread_mutex_lock (&thread_admin_mutex);
t->next_thread = all_threads;
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ t->guile_mode = 1;
+
SCM_NEWSMOB (t->handle, scm_tc16_thread, t);
- scm_gc_register_collectable_memory (t, sizeof (scm_i_thread), "thread");
+
t->continuation_root = scm_cons (t->handle, SCM_EOL);
t->continuation_base = t->base;
t->vm = SCM_BOOL_F;
while (!scm_is_null (t->mutexes))
{
- SCM mutex = SCM_CAR (t->mutexes);
- fat_mutex *m = SCM_MUTEX_DATA (mutex);
- scm_i_pthread_mutex_lock (&m->lock);
+ SCM mutex = SCM_WEAK_PAIR_CAR (t->mutexes);
- unblock_from_queue (m->waiting);
+ if (!SCM_UNBNDP (mutex))
+ {
+ fat_mutex *m = SCM_MUTEX_DATA (mutex);
- scm_i_pthread_mutex_unlock (&m->lock);
- t->mutexes = SCM_CDR (t->mutexes);
+ scm_i_pthread_mutex_lock (&m->lock);
+ unblock_from_queue (m->waiting);
+ scm_i_pthread_mutex_unlock (&m->lock);
+ }
+
+ t->mutexes = SCM_WEAK_PAIR_CDR (t->mutexes);
}
scm_i_pthread_mutex_unlock (&t->admin_mutex);
t->held_mutex = NULL;
}
- scm_i_pthread_setspecific (scm_i_thread_key, v);
+ SET_CURRENT_THREAD (v);
/* Ensure the signal handling thread has been launched, because we might be
shutting it down. */
/* Unblocking the joining threads needs to happen in guile mode
since the queue is a SCM data structure. */
- scm_with_guile (do_thread_exit, v);
+
+ /* Note: Since `do_thread_exit ()' uses allocates memory via `libgc', we
+ assume the GC is usable at this point, and notably that thread-local
+ storage (TLS) hasn't been deallocated yet. */
+ do_thread_exit (v);
/* Removing ourself from the list of all threads needs to happen in
non-guile mode since all SCM values on our stack become
if (*tp == t)
{
*tp = t->next_thread;
+
+ /* GC-robust */
+ t->next_thread = NULL;
+
break;
}
thread_count--;
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
- scm_i_pthread_setspecific (scm_i_thread_key, NULL);
+ SET_CURRENT_THREAD (NULL);
}
+#ifndef SCM_HAVE_THREAD_STORAGE_CLASS
+
static scm_i_pthread_once_t init_thread_key_once = SCM_I_PTHREAD_ONCE_INIT;
static void
init_thread_key (void)
{
- scm_i_pthread_key_create (&scm_i_thread_key, on_thread_exit);
+ scm_i_pthread_key_create (&scm_i_thread_key, NULL);
}
+#endif
+
/* Perform any initializations necessary to bring the current thread
into guile mode, initializing Guile itself, if necessary.
{
scm_i_thread *t;
+#ifndef SCM_HAVE_THREAD_STORAGE_CLASS
scm_i_pthread_once (&init_thread_key_once, init_thread_key);
+#endif
- if ((t = SCM_I_CURRENT_THREAD) == NULL)
+ t = SCM_I_CURRENT_THREAD;
+ if (t == NULL)
{
/* This thread has not been guilified yet.
*/
t->base = base;
#endif
- scm_enter_guile ((scm_t_guile_ticket) t);
+ t->top = NULL;
return 1;
}
else
#ifndef PTHREAD_ATTR_GETSTACK_WORKS
if ((void *)&attr < start || (void *)&attr >= end)
- return scm_get_stack_base ();
+ return (SCM_STACKITEM *) GC_stackbottom;
else
#endif
{
}
}
-#elif HAVE_PTHREAD_GET_STACKADDR_NP
+#elif defined HAVE_PTHREAD_GET_STACKADDR_NP
/* This method for MacOS X.
It'd be nice if there was some documentation on pthread_get_stackaddr_np,
but as of 2006 there's nothing obvious at apple.com. */
static SCM_STACKITEM *
get_thread_stack_base ()
{
- return scm_get_stack_base ();
+ return (SCM_STACKITEM *) GC_stackbottom;
}
#endif /* pthread methods of get_thread_stack_base */
static SCM_STACKITEM *
get_thread_stack_base ()
{
- return scm_get_stack_base ();
+ return (SCM_STACKITEM *) GC_stackbottom;
}
#endif /* !SCM_USE_PTHREAD_THREADS */
SCM_UNUSED static void
scm_leave_guile_cleanup (void *x)
{
- scm_leave_guile ();
+ on_thread_exit (SCM_I_CURRENT_THREAD);
}
void *
scm_i_pthread_cleanup_push (scm_leave_guile_cleanup, NULL);
res = scm_c_with_continuation_barrier (func, data);
scm_i_pthread_cleanup_pop (0);
- scm_leave_guile ();
}
else
res = scm_c_with_continuation_barrier (func, data);
return res;
}
+\f
+/*** Non-guile mode. */
+
+#ifdef HAVE_GC_DO_BLOCKING
+
+# ifndef HAVE_GC_FN_TYPE
+/* This typedef is missing from the public headers of GC 7.1 and earlier. */
+typedef void * (* GC_fn_type) (void *);
+# endif /* HAVE_GC_FN_TYPE */
+
+# ifndef HAVE_DECL_GC_DO_BLOCKING
+/* This declaration is missing from the public headers of GC 7.1. */
+extern void GC_do_blocking (GC_fn_type, void *);
+# endif /* HAVE_DECL_GC_DO_BLOCKING */
+
+struct without_guile_arg
+{
+ void * (*function) (void *);
+ void *data;
+ void *result;
+};
+
+static void
+without_guile_trampoline (void *closure)
+{
+ struct without_guile_arg *arg;
+
+ SCM_I_CURRENT_THREAD->guile_mode = 0;
+
+ arg = (struct without_guile_arg *) closure;
+ arg->result = arg->function (arg->data);
+
+ SCM_I_CURRENT_THREAD->guile_mode = 1;
+}
+
+#endif /* HAVE_GC_DO_BLOCKING */
+
+
void *
scm_without_guile (void *(*func)(void *), void *data)
{
- void *res;
- scm_t_guile_ticket t;
- t = scm_leave_guile ();
- res = func (data);
- scm_enter_guile (t);
- return res;
+ void *result;
+
+#ifdef HAVE_GC_DO_BLOCKING
+ if (SCM_I_CURRENT_THREAD->guile_mode)
+ {
+ struct without_guile_arg arg;
+
+ arg.function = func;
+ arg.data = data;
+ GC_do_blocking ((GC_fn_type) without_guile_trampoline, &arg);
+ result = arg.result;
+ }
+ else
+#endif
+ result = func (data);
+
+ return result;
}
+\f
/*** Thread creation */
typedef struct {
else
t->result = scm_catch (SCM_BOOL_T, thunk, handler);
+ /* Trigger a call to `on_thread_exit ()'. */
+ pthread_exit (NULL);
+
return 0;
}
}
#undef FUNC_NAME
-static SCM
-fat_mutex_mark (SCM mx)
-{
- fat_mutex *m = SCM_MUTEX_DATA (mx);
- scm_gc_mark (m->owner);
- return m->waiting;
-}
static size_t
fat_mutex_free (SCM mx)
{
fat_mutex *m = SCM_MUTEX_DATA (mx);
scm_i_pthread_mutex_destroy (&m->lock);
- scm_gc_free (m, sizeof (fat_mutex), "mutex");
return 0;
}
{
scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
scm_i_pthread_mutex_lock (&t->admin_mutex);
- t->mutexes = scm_cons (mutex, t->mutexes);
+
+ /* Only keep a weak reference to MUTEX so that it's not
+ retained when not referenced elsewhere (bug #27450). Note
+ that the weak pair itself it still retained, but it's better
+ than retaining MUTEX and the threads referred to by its
+ associated queue. */
+ t->mutexes = scm_weak_car_pair (mutex, t->mutexes);
+
scm_i_pthread_mutex_unlock (&t->admin_mutex);
}
*ret = 1;
fat_mutex_unlock (SCM mutex, SCM cond,
const scm_t_timespec *waittime, int relock)
{
+ SCM owner;
fat_mutex *m = SCM_MUTEX_DATA (mutex);
fat_cond *c = NULL;
scm_i_thread *t = SCM_I_CURRENT_THREAD;
scm_i_scm_pthread_mutex_lock (&m->lock);
- SCM owner = m->owner;
+ owner = m->owner;
if (!scm_is_eq (owner, scm_current_thread ()))
{
}
#undef FUNC_NAME
-static SCM
-fat_cond_mark (SCM cv)
-{
- fat_cond *c = SCM_CONDVAR_DATA (cv);
- return c->waiting;
-}
-
-static size_t
-fat_cond_free (SCM mx)
-{
- fat_cond *c = SCM_CONDVAR_DATA (mx);
- scm_gc_free (c, sizeof (fat_cond), "condition-variable");
- return 0;
-}
-
static int
fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
}
#undef FUNC_NAME
-/*** Marking stacks */
-/* XXX - what to do with this? Do we need to handle this for blocked
- threads as well?
-*/
-#ifdef __ia64__
-# define SCM_MARK_BACKING_STORE() do { \
- ucontext_t ctx; \
- SCM_STACKITEM * top, * bot; \
- getcontext (&ctx); \
- scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
- ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
- / sizeof (SCM_STACKITEM))); \
- bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
- top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
- scm_mark_locations (bot, top - bot); } while (0)
-#else
-# define SCM_MARK_BACKING_STORE()
-#endif
+\f
+/*** Select */
-void
-scm_threads_mark_stacks (void)
+struct select_args
{
- scm_i_thread *t;
- for (t = all_threads; t; t = t->next_thread)
- {
- /* Check that thread has indeed been suspended.
- */
- assert (t->top);
+ int nfds;
+ SELECT_TYPE *read_fds;
+ SELECT_TYPE *write_fds;
+ SELECT_TYPE *except_fds;
+ struct timeval *timeout;
- scm_gc_mark (t->handle);
+ int result;
+ int errno_value;
+};
-#if SCM_STACK_GROWS_UP
- scm_mark_locations (t->base, t->top - t->base);
-#else
- scm_mark_locations (t->top, t->base - t->top);
-#endif
- scm_mark_locations ((void *) &t->regs,
- ((size_t) sizeof(t->regs)
- / sizeof (SCM_STACKITEM)));
- }
+static void *
+do_std_select (void *args)
+{
+ struct select_args *select_args;
- SCM_MARK_BACKING_STORE ();
-}
+ select_args = (struct select_args *) args;
-/*** Select */
+ select_args->result =
+ select (select_args->nfds,
+ select_args->read_fds, select_args->write_fds,
+ select_args->except_fds, select_args->timeout);
+ select_args->errno_value = errno;
+
+ return NULL;
+}
int
scm_std_select (int nfds,
fd_set my_readfds;
int res, eno, wakeup_fd;
scm_i_thread *t = SCM_I_CURRENT_THREAD;
- scm_t_guile_ticket ticket;
+ struct select_args args;
if (readfds == NULL)
{
SCM_TICK;
wakeup_fd = t->sleep_pipe[0];
- ticket = scm_leave_guile ();
FD_SET (wakeup_fd, readfds);
if (wakeup_fd >= nfds)
nfds = wakeup_fd+1;
- res = select (nfds, readfds, writefds, exceptfds, timeout);
- t->sleep_fd = -1;
- eno = errno;
- scm_enter_guile (ticket);
+ args.nfds = nfds;
+ args.read_fds = readfds;
+ args.write_fds = writefds;
+ args.except_fds = exceptfds;
+ args.timeout = timeout;
+
+ /* Explicitly cooperate with the GC. */
+ scm_without_guile (do_std_select, &args);
+
+ res = args.result;
+ eno = args.errno_value;
+
+ t->sleep_fd = -1;
scm_i_reset_sleep (t);
if (res > 0 && FD_ISSET (wakeup_fd, readfds))
#if SCM_USE_PTHREAD_THREADS
+/* It seems reasonable to not run procedures related to mutex and condition
+ variables within `GC_do_blocking ()' since, (i) the GC can operate even
+ without it, and (ii) the only potential gain would be GC latency. See
+ http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2245/focus=2251
+ for a discussion of the pros and cons. */
+
int
scm_pthread_mutex_lock (scm_i_pthread_mutex_t *mutex)
{
- if (scm_i_pthread_mutex_trylock (mutex) == 0)
- return 0;
- else
- {
- scm_t_guile_ticket t = scm_leave_guile ();
- int res = scm_i_pthread_mutex_lock (mutex);
- scm_enter_guile (t);
- return res;
- }
+ int res = scm_i_pthread_mutex_lock (mutex);
+ return res;
}
static void
int
scm_pthread_cond_wait (scm_i_pthread_cond_t *cond, scm_i_pthread_mutex_t *mutex)
{
- scm_t_guile_ticket t = scm_leave_guile ();
- ((scm_i_thread *)t)->held_mutex = mutex;
- int res = scm_i_pthread_cond_wait (cond, mutex);
- ((scm_i_thread *)t)->held_mutex = NULL;
- scm_enter_guile (t);
+ int res;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ t->held_mutex = mutex;
+ res = scm_i_pthread_cond_wait (cond, mutex);
+ t->held_mutex = NULL;
+
return res;
}
scm_i_pthread_mutex_t *mutex,
const scm_t_timespec *wt)
{
- scm_t_guile_ticket t = scm_leave_guile ();
- ((scm_i_thread *)t)->held_mutex = mutex;
- int res = scm_i_pthread_cond_timedwait (cond, mutex, wt);
- ((scm_i_thread *)t)->held_mutex = NULL;
- scm_enter_guile (t);
+ int res;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ t->held_mutex = mutex;
+ res = scm_i_pthread_cond_timedwait (cond, mutex, wt);
+ t->held_mutex = NULL;
+
return res;
}
#undef FUNC_NAME
static scm_i_pthread_cond_t wake_up_cond;
-int scm_i_thread_go_to_sleep;
static int threads_initialized_p = 0;
-void
-scm_i_thread_put_to_sleep ()
-{
- if (threads_initialized_p)
- {
- scm_i_thread *t;
-
- scm_leave_guile ();
- scm_i_pthread_mutex_lock (&thread_admin_mutex);
-
- /* Signal all threads to go to sleep
- */
- scm_i_thread_go_to_sleep = 1;
- for (t = all_threads; t; t = t->next_thread)
- scm_i_pthread_mutex_lock (&t->heap_mutex);
- scm_i_thread_go_to_sleep = 0;
- }
-}
-
-void
-scm_i_thread_invalidate_freelists ()
-{
- /* thread_admin_mutex is already locked. */
-
- scm_i_thread *t;
- for (t = all_threads; t; t = t->next_thread)
- if (t != SCM_I_CURRENT_THREAD)
- t->clear_freelists_p = 1;
-}
-
-void
-scm_i_thread_wake_up ()
-{
- if (threads_initialized_p)
- {
- scm_i_thread *t;
-
- scm_i_pthread_cond_broadcast (&wake_up_cond);
- for (t = all_threads; t; t = t->next_thread)
- scm_i_pthread_mutex_unlock (&t->heap_mutex);
- scm_i_pthread_mutex_unlock (&thread_admin_mutex);
- scm_enter_guile ((scm_t_guile_ticket) SCM_I_CURRENT_THREAD);
- }
-}
-
-void
-scm_i_thread_sleep_for_gc ()
-{
- scm_i_thread *t = suspend ();
-
- /* Don't put t->heap_mutex in t->held_mutex here, because if the
- thread is cancelled during the cond wait, the thread's cleanup
- function (scm_leave_guile_cleanup) will handle unlocking the
- heap_mutex, so we don't need to do that again in on_thread_exit.
- */
- scm_i_pthread_cond_wait (&wake_up_cond, &t->heap_mutex);
-
- resume (t);
-}
/* This mutex is used by SCM_CRITICAL_SECTION_START/END.
*/
scm_i_pthread_mutex_t scm_i_critical_section_mutex;
-int scm_i_critical_section_level = 0;
static SCM dynwind_critical_section_mutex;
/*** Initialization */
-scm_i_pthread_key_t scm_i_freelist, scm_i_freelist2;
scm_i_pthread_mutex_t scm_i_misc_mutex;
#if SCM_USE_PTHREAD_THREADS
scm_i_pthread_mutexattr_recursive);
scm_i_pthread_mutex_init (&scm_i_misc_mutex, NULL);
scm_i_pthread_cond_init (&wake_up_cond, NULL);
- scm_i_pthread_key_create (&scm_i_freelist, NULL);
- scm_i_pthread_key_create (&scm_i_freelist2, NULL);
guilify_self_1 (base);
}
scm_init_threads ()
{
scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_i_thread));
- scm_set_smob_mark (scm_tc16_thread, thread_mark);
scm_set_smob_print (scm_tc16_thread, thread_print);
- scm_set_smob_free (scm_tc16_thread, thread_free);
scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (fat_mutex));
- scm_set_smob_mark (scm_tc16_mutex, fat_mutex_mark);
scm_set_smob_print (scm_tc16_mutex, fat_mutex_print);
scm_set_smob_free (scm_tc16_mutex, fat_mutex_free);
scm_tc16_condvar = scm_make_smob_type ("condition-variable",
sizeof (fat_cond));
- scm_set_smob_mark (scm_tc16_condvar, fat_cond_mark);
scm_set_smob_print (scm_tc16_condvar, fat_cond_print);
- scm_set_smob_free (scm_tc16_condvar, fat_cond_free);
scm_i_default_dynamic_state = SCM_BOOL_F;
guilify_self_2 (SCM_BOOL_F);
threads_initialized_p = 1;
- dynwind_critical_section_mutex =
- scm_permanent_object (scm_make_recursive_mutex ());
+ dynwind_critical_section_mutex = scm_make_recursive_mutex ();
}
void
scm_init_threads_default_dynamic_state ()
{
SCM state = scm_make_dynamic_state (scm_current_dynamic_state ());
- scm_i_default_dynamic_state = scm_permanent_object (state);
+ scm_i_default_dynamic_state = state;
}
void
#include "libguile/threads.x"
}
+\f
+/* IA64-specific things. */
+
+#ifdef __ia64__
+# ifdef __hpux
+# include <sys/param.h>
+# include <sys/pstat.h>
+void *
+scm_ia64_register_backing_store_base (void)
+{
+ struct pst_vm_status vm_status;
+ int i = 0;
+ while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1)
+ if (vm_status.pst_type == PS_RSESTACK)
+ return (void *) vm_status.pst_vaddr;
+ abort ();
+}
+void *
+scm_ia64_ar_bsp (const void *ctx)
+{
+ uint64_t bsp;
+ __uc_get_ar_bsp (ctx, &bsp);
+ return (void *) bsp;
+}
+# endif /* hpux */
+# ifdef linux
+# include <ucontext.h>
+void *
+scm_ia64_register_backing_store_base (void)
+{
+ extern void *__libc_ia64_register_backing_store_base;
+ return __libc_ia64_register_backing_store_base;
+}
+void *
+scm_ia64_ar_bsp (const void *opaque)
+{
+ const ucontext_t *ctx = opaque;
+ return (void *) ctx->uc_mcontext.sc_ar_bsp;
+}
+# endif /* linux */
+#endif /* __ia64__ */
+
+
/*
Local Variables:
c-file-style: "gnu"
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 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
int canceled;
int exited;
+ /* Boolean indicating whether the thread is in guile mode. */
+ int guile_mode;
+
SCM sleep_object;
scm_i_pthread_mutex_t *sleep_mutex;
scm_i_pthread_cond_t sleep_cond;
int sleep_fd, sleep_pipe[2];
- /* This mutex represents this threads right to access the heap.
- That right can temporarily be taken away by the GC.
- */
- scm_i_pthread_mutex_t heap_mutex;
-
- /* Boolean tracking whether the above mutex is currently locked by
- this thread. This is equivalent to whether or not the thread is
- in "Guile mode". This field doesn't need any protection because
- it is only ever set or tested by the owning thread.
- */
- int heap_mutex_locked_by_self;
-
- /* The freelists of this thread. Each thread has its own lists so
- that they can all allocate concurrently.
- */
- SCM freelist, freelist2;
- int clear_freelists_p; /* set if GC was done while thread was asleep */
- int gc_running_p; /* non-zero while this thread does GC or a
- sweep. */
+ /* Information about the Boehm-GC mark stack during the mark phase. This
+ is used by `scm_gc_mark ()'. */
+ void *current_mark_stack_ptr;
+ void *current_mark_stack_limit;
/* Other thread local things.
*/
SCM dynamic_state;
- scm_t_debug_frame *last_debug_frame;
SCM dynwinds;
/* For system asyncs.
scm_t_contregs *pending_rbs_continuation;
#endif
+ /* Whether this thread is in a critical section. */
+ int critical_section_level;
+
} scm_i_thread;
#define SCM_I_IS_THREAD(x) SCM_SMOB_PREDICATE (scm_tc16_thread, x)
void *data, SCM parent);
-extern int scm_i_thread_go_to_sleep;
-
-SCM_INTERNAL void scm_i_thread_put_to_sleep (void);
-SCM_INTERNAL void scm_i_thread_wake_up (void);
-SCM_INTERNAL void scm_i_thread_invalidate_freelists (void);
-void scm_i_thread_sleep_for_gc (void);
+void scm_threads_prehistory (SCM_STACKITEM *);
+void scm_threads_init_first_thread (void);
-SCM_INTERNAL void scm_threads_prehistory (SCM_STACKITEM *);
-SCM_INTERNAL void scm_threads_init_first_thread (void);
-SCM_INTERNAL void scm_threads_mark_stacks (void);
SCM_INTERNAL void scm_init_threads (void);
SCM_INTERNAL void scm_init_thread_procs (void);
SCM_INTERNAL void scm_init_threads_default_dynamic_state (void);
#define SCM_THREAD_SWITCHING_CODE \
-do { \
- if (scm_i_thread_go_to_sleep) \
- scm_i_thread_sleep_for_gc (); \
-} while (0)
+ do { } while (0)
SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
SCM_API SCM scm_yield (void);
SCM_API void scm_dynwind_critical_section (SCM mutex);
-#define SCM_I_CURRENT_THREAD \
- ((scm_i_thread *) scm_i_pthread_getspecific (scm_i_thread_key))
-SCM_API scm_i_pthread_key_t scm_i_thread_key;
+#ifdef BUILDING_LIBGUILE
+
+# ifdef SCM_HAVE_THREAD_STORAGE_CLASS
+
+SCM_INTERNAL SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread;
+# define SCM_I_CURRENT_THREAD (scm_i_current_thread)
+
+# else /* !SCM_HAVE_THREAD_STORAGE_CLASS */
+
+SCM_INTERNAL scm_i_pthread_key_t scm_i_thread_key;
+# define SCM_I_CURRENT_THREAD \
+ ((scm_i_thread *) scm_i_pthread_getspecific (scm_i_thread_key))
+
+# endif /* !SCM_HAVE_THREAD_STORAGE_CLASS */
+
+# define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
+# define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
+
+#endif /* BUILDING_LIBGUILE */
-#define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
-#define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
-#define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame)
-#define scm_i_set_last_debug_frame(f) \
- (SCM_I_CURRENT_THREAD->last_debug_frame = (f))
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_misc_mutex;
-/* 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, 2009 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
#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
-#define ACTIVATEJB(x) \
- (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
-#define DEACTIVATEJB(x) \
- (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
+#define JBACTIVE(OBJ) (SCM_SMOB_FLAGS (OBJ) & 1L)
+#define ACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 1L))
+#define DEACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 0L))
-#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
-#define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
-#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
-#define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
-#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
-#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
+#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_SMOB_DATA_1 (OBJ))
+#define SETJBJMPBUF(x, v) (SCM_SET_SMOB_DATA_1 ((x), (scm_t_bits) (v)))
+#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_SMOB_DATA_3 (x))
+#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_SMOB_DATA_3 ((x), (scm_t_bits) (v)))
static int
jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
struct pre_unwind_data pre_unwind;
vm = scm_the_vm ();
- if (SCM_NFALSEP (vm))
+ if (scm_is_true (vm))
{
sp = SCM_VM_DATA (vm)->sp;
fp = SCM_VM_DATA (vm)->fp;
answer = SCM_EOL;
scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
SETJBJMPBUF(jmpbuf, &jbr.buf);
- SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());
pre_unwind.handler = pre_unwind_handler;
pre_unwind.handler_data = pre_unwind_handler_data;
throw_tag = jbr.throw_tag;
jbr.throw_tag = SCM_EOL;
jbr.retval = SCM_EOL;
- if (SCM_NFALSEP (vm))
+ if (scm_is_true (vm))
{
SCM_VM_DATA (vm)->sp = sp;
SCM_VM_DATA (vm)->fp = fp;
- (sp + 1 - SCM_VM_DATA (vm)->stack_base)) * sizeof(SCM));
#endif
}
- else if (SCM_NFALSEP ((vm = scm_the_vm ())))
+ else if (scm_is_true ((vm = scm_the_vm ())))
{
/* oof, it's possible this catch was called before the vm was
booted... yick. anyway, try to reset the vm stack. */
static int
pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1 (closure);
+ struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_SMOB_DATA_1 (closure);
char buf[200];
sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
SCM dynpair = SCM_UNDEFINED;
SCM winds;
- if (scm_i_critical_section_level)
+ if (SCM_I_CURRENT_THREAD->critical_section_level)
{
SCM s = args;
int i = 0;
else
{
struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
if (!c->running)
break;
}
if (SCM_PRE_UNWIND_DATA_P (jmpbuf))
{
struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
SCM handle, answer;
/* For old-style lazy-catch behaviour, we unwind the dynamic
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
jbr->throw_tag = key;
jbr->retval = args;
- scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf));
SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1);
}
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+ * 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eq.h"
+#include "libguile/lang.h"
+
+#include "libguile/validate.h"
+#include "libguile/list.h"
+#include "libguile/vectors.h"
+#include "libguile/srcprop.h"
+#include "libguile/trees.h"
+
+#include <stdarg.h>
+
+
+/* scm_copy_tree creates deep copies of pairs and vectors, but not of any other
+ * data types.
+ *
+ * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
+ * pattern is used to detect cycles. In fact, the pattern is used in two
+ * dimensions, vertical (indicated in the code by the variable names 'hare'
+ * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
+ * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
+ * takes one.
+ *
+ * The vertical dimension corresponds to recursive calls to function
+ * copy_tree: This happens when descending into vector elements, into cars of
+ * lists and into the cdr of an improper list. In this dimension, the
+ * tortoise follows the hare by using the processor stack: Every stack frame
+ * will hold an instance of struct t_trace. These instances are connected in
+ * a way that represents the trace of the hare, which thus can be followed by
+ * the tortoise. The tortoise will always point to struct t_trace instances
+ * relating to SCM objects that have already been copied. Thus, a cycle is
+ * detected if the tortoise and the hare point to the same object,
+ *
+ * The horizontal dimension is within one execution of copy_tree, when the
+ * function cdr's along the pairs of a list. This is the standard
+ * hare-and-tortoise implementation, found several times in guile. */
+
+struct t_trace {
+ struct t_trace *trace; /* These pointers form a trace along the stack. */
+ SCM obj; /* The object handled at the respective stack frame.*/
+};
+
+static SCM
+copy_tree (struct t_trace *const hare,
+ struct t_trace *tortoise,
+ unsigned int tortoise_delay);
+
+SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
+ (SCM obj),
+ "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
+ "the new data structure. @code{copy-tree} recurses down the\n"
+ "contents of both pairs and vectors (since both cons cells and vector\n"
+ "cells may point to arbitrary objects), and stops recursing when it hits\n"
+ "any other object.")
+#define FUNC_NAME s_scm_copy_tree
+{
+ /* Prepare the trace along the stack. */
+ struct t_trace trace;
+ trace.obj = obj;
+
+ /* In function copy_tree, if the tortoise makes its step, it will do this
+ * before the hare has the chance to move. Thus, we have to make sure that
+ * the very first step of the tortoise will not happen after the hare has
+ * really made two steps. This is achieved by passing '2' as the initial
+ * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
+ * a bigger advantage may improve performance slightly. */
+ return copy_tree (&trace, &trace, 2);
+}
+#undef FUNC_NAME
+
+
+static SCM
+copy_tree (struct t_trace *const hare,
+ struct t_trace *tortoise,
+ unsigned int tortoise_delay)
+#define FUNC_NAME s_scm_copy_tree
+{
+ if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
+ {
+ return hare->obj;
+ }
+ else
+ {
+ /* Prepare the trace along the stack. */
+ struct t_trace new_hare;
+ hare->trace = &new_hare;
+
+ /* The tortoise will make its step after the delay has elapsed. Note
+ * that in contrast to the typical hare-and-tortoise pattern, the step
+ * of the tortoise happens before the hare takes its steps. This is, in
+ * principle, no problem, except for the start of the algorithm: Then,
+ * it has to be made sure that the hare actually gets its advantage of
+ * two steps. */
+ if (tortoise_delay == 0)
+ {
+ tortoise_delay = 1;
+ tortoise = tortoise->trace;
+ if (SCM_UNLIKELY (scm_is_eq (hare->obj, tortoise->obj)))
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, hare->obj,
+ "expected non-circular data structure");
+ }
+ else
+ {
+ --tortoise_delay;
+ }
+
+ if (scm_is_simple_vector (hare->obj))
+ {
+ size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
+ SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
+
+ /* Each vector element is copied by recursing into copy_tree, having
+ * the tortoise follow the hare into the depths of the stack. */
+ unsigned long int i;
+ for (i = 0; i < length; ++i)
+ {
+ SCM new_element;
+ new_hare.obj = SCM_SIMPLE_VECTOR_REF (hare->obj, i);
+ new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SIMPLE_VECTOR_SET (new_vector, i, new_element);
+ }
+
+ return new_vector;
+ }
+ else /* scm_is_pair (hare->obj) */
+ {
+ SCM result;
+ SCM tail;
+
+ SCM rabbit = hare->obj;
+ SCM turtle = hare->obj;
+
+ SCM copy;
+
+ /* The first pair of the list is treated specially, in order to
+ * preserve a potential source code position. */
+ result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCAR (tail, copy);
+
+ /* The remaining pairs of the list are copied by, horizontally,
+ * having the turtle follow the rabbit, and, vertically, having the
+ * tortoise follow the hare into the depths of the stack. */
+ rabbit = SCM_CDR (rabbit);
+ while (scm_is_pair (rabbit))
+ {
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
+ tail = SCM_CDR (tail);
+
+ rabbit = SCM_CDR (rabbit);
+ if (scm_is_pair (rabbit))
+ {
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
+ tail = SCM_CDR (tail);
+ rabbit = SCM_CDR (rabbit);
+
+ turtle = SCM_CDR (turtle);
+ if (SCM_UNLIKELY (scm_is_eq (rabbit, turtle)))
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, rabbit,
+ "expected non-circular data structure");
+ }
+ }
+
+ /* We have to recurse into copy_tree again for the last cdr, in
+ * order to handle the situation that it holds a vector. */
+ new_hare.obj = rabbit;
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, copy);
+
+ return result;
+ }
+ }
+}
+#undef FUNC_NAME
+
+\f
+void
+scm_init_trees ()
+{
+#include "libguile/trees.x"
+}
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_TREES_H
+#define SCM_TREES_H
+
+/* Copyright (C) 2009
+ * 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_copy_tree (SCM obj);
+
+\f
+
+/* Guile internal functions */
+
+SCM_INTERNAL void scm_init_trees (void);
+
+#endif /* SCM_TREES_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+#!/usr/bin/perl
+# unidata_to_charset.pl --- Compute SRFI-14 charsets from UnicodeData.txt
+#
+# Copyright (C) 2009 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
+
+open(my $in, "<", "UnicodeData.txt") or die "Can't open UnicodeData.txt: $!";
+open(my $out, ">", "srfi-14.i.c") or die "Can't open srfi-14.i.c: $!";
+
+# For Unicode, we follow Java's specification: a character is
+# lowercase if
+# * it is not in the range [U+2000,U+2FFF], and
+# * the Unicode attribute table does not give a lowercase mapping
+# for it, and
+# * at least one of the following is true:
+# o the Unicode attribute table gives a mapping to uppercase
+# for the character, or
+# o the name for the character in the Unicode attribute table
+# contains the words "SMALL LETTER" or "SMALL LIGATURE".
+
+sub lower_case {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (($codepoint < 0x2000 || $codepoint > 0x2FFF)
+ && (!defined($lowercase) || $lowercase eq "")
+ && ((defined($uppercase) && $uppercase ne "")
+ || ($name =~ /(SMALL LETTER|SMALL LIGATURE)/))) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# For Unicode, we follow Java's specification: a character is
+# uppercase if
+# * it is not in the range [U+2000,U+2FFF], and
+# * the Unicode attribute table does not give an uppercase mapping
+# for it (this excludes titlecase characters), and
+# * at least one of the following is true:
+# o the Unicode attribute table gives a mapping to lowercase
+# for the character, or
+# o the name for the character in the Unicode attribute table
+# contains the words "CAPITAL LETTER" or "CAPITAL LIGATURE".
+
+sub upper_case {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (($codepoint < 0x2000 || $codepoint > 0x2FFF)
+ && (!defined($uppercase) || $uppercase eq "")
+ && ((defined($lowercase) && $lowercase ne "")
+ || ($name =~ /(CAPITAL LETTER|CAPITAL LIGATURE)/))) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# A character is titlecase if it has the category Lt in the character
+# attribute database.
+
+sub title_case {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (defined($category) && $category eq "Lt") {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# A letter is any character with one of the letter categories (Lu, Ll,
+# Lt, Lm, Lo) in the Unicode character database.
+
+sub letter {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (defined($category) && ($category eq "Lu"
+ || $category eq "Ll"
+ || $category eq "Lt"
+ || $category eq "Lm"
+ || $category eq "Lo")) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# A character is a digit if it has the category Nd in the character
+# attribute database. In Latin-1 and ASCII, the only such characters
+# are 0123456789. In Unicode, there are other digit characters in
+# other code blocks, such as Gujarati digits and Tibetan digits.
+
+sub digit {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (defined($category) && $category eq "Nd") {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# The only hex digits are 0123456789abcdefABCDEF.
+
+sub hex_digit {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (($codepoint >= 0x30 && $codepoint <= 0x39)
+ || ($codepoint >= 0x41 && $codepoint <= 0x46)
+ || ($codepoint >= 0x61 && $codepoint <= 0x66)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# The union of char-set:letter and char-set:digit.
+
+sub letter_plus_digit {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (letter($codepoint, $name, $category, $uppercase, $lowercase)
+ || digit($codepoint, $name, $category, $uppercase, $lowercase)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# Characters that would 'use ink' when printed
+sub graphic {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if ($category =~ (/L|M|N|P|S/)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# A whitespace character is either
+# * a character with one of the space, line, or paragraph separator
+# categories (Zs, Zl or Zp) of the Unicode character database.
+# * U+0009 Horizontal tabulation (\t control-I)
+# * U+000A Line feed (\n control-J)
+# * U+000B Vertical tabulation (\v control-K)
+# * U+000C Form feed (\f control-L)
+# * U+000D Carriage return (\r control-M)
+
+sub whitespace {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if ($category =~ (/Zs|Zl|Zp/)
+ || $codepoint == 0x9
+ || $codepoint == 0xA
+ || $codepoint == 0xB
+ || $codepoint == 0xC
+ || $codepoint == 0xD) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# A printing character is one that would occupy space when printed,
+# i.e., a graphic character or a space character. char-set:printing is
+# the union of char-set:whitespace and char-set:graphic.
+
+sub printing {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (whitespace($codepoint, $name, $category, $uppercase, $lowercase)
+ || graphic($codepoint, $name, $category, $uppercase, $lowercase)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# The ISO control characters are the Unicode/Latin-1 characters in the
+# ranges [U+0000,U+001F] and [U+007F,U+009F].
+
+sub iso_control {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if (($codepoint >= 0x00 && $codepoint <= 0x1F)
+ || ($codepoint >= 0x7F && $codepoint <= 0x9F)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# A punctuation character is any character that has one of the
+# punctuation categories in the Unicode character database (Pc, Pd,
+# Ps, Pe, Pi, Pf, or Po.)
+
+# Note that srfi-14 gives conflicting requirements!! It claims that
+# only the Unicode punctuation is necessary, but, explicitly calls out
+# the soft hyphen character (U+00AD) as punctution. Current versions
+# of Unicode consider U+00AD to be a formatting character, not
+# punctuation.
+
+sub punctuation {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if ($category =~ (/P/)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# A symbol is any character that has one of the symbol categories in
+# the Unicode character database (Sm, Sc, Sk, or So).
+
+sub symbol {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if ($category =~ (/S/)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# Blank chars are horizontal whitespace. A blank character is either
+# * a character with the space separator category (Zs) in the
+# Unicode character database.
+# * U+0009 Horizontal tabulation (\t control-I)
+sub blank {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if ($category =~ (/Zs/)
+ || $codepoint == 0x9) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# ASCII
+sub ascii {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if ($codepoint <= 0x7F) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# Empty
+sub empty {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ return 0;
+}
+
+# Designated -- All characters except for the surrogates
+sub designated {
+ my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
+ if ($category =~ (/Cs/)) {
+ return 0;
+ } else {
+ return 1;
+ }
+}
+
+
+# The procedure generates the two C structures necessary to describe a
+# given category.
+sub compute {
+ my($f) = @_;
+ my $start = -1;
+ my $end = -1;
+ my $len = 0;
+ my @rstart = (-1);
+ my @rend = (-1);
+
+ seek($in, 0, 0) or die "Can't seek to beginning of file: $!";
+
+ print "$f\n";
+
+ while (<$in>) {
+ # Parse the 14 column, semicolon-delimited UnicodeData.txt
+ # file
+ chomp;
+ my(@fields) = split(/;/);
+
+ # The codepoint: an integer
+ my $codepoint = hex($fields[0]);
+
+ # If this is a character range, the last character in this
+ # range
+ my $codepoint_end = $codepoint;
+
+ # The name of the character
+ my $name = $fields[1];
+
+ # A two-character category code, such as Ll (lower-case
+ # letter)
+ my $category = $fields[2];
+
+ # The codepoint of the uppercase version of this char
+ my $uppercase = $fields[12];
+
+ # The codepoint of the lowercase version of this char
+ my $lowercase = $fields[13];
+
+ my $pass = &$f($codepoint,$name,$category,$uppercase,$lowercase);
+ if ($pass == 1) {
+
+ # Some pairs of lines in UnicodeData.txt delimit ranges of
+ # characters.
+ if ($name =~ /First/) {
+ $line = <$in>;
+ die $! if $!;
+ $codepoint_end = hex( (split(/;/, $line))[0] );
+ }
+
+ # Compute ranges of characters [start:end] that meet the
+ # criteria. Store the ranges.
+ if ($start == -1) {
+ $start = $codepoint;
+ $end = $codepoint_end;
+ } elsif ($end + 1 == $codepoint) {
+ $end = $codepoint_end;
+ } else {
+ $rstart[$len] = $start;
+ $rend[$len] = $end;
+ $len++;
+ $start = $codepoint;
+ $end = $codepoint_end;
+ }
+ }
+ }
+
+ # Extra logic to ensure that the last range is included
+ if ($start != -1) {
+ if ($len > 0 && $rstart[@rstart-1] != $start) {
+ $rstart[$len] = $start;
+ $rend[$len] = $end;
+ $len++;
+ } elsif ($len == 0) {
+ $rstart[0] = $start;
+ $rend[0] = $end;
+ }
+ }
+
+ # Print the C struct that contains the range list.
+ print $out "scm_t_char_range cs_" . $f . "_ranges[] = {\n";
+ if ($rstart[0] != -1) {
+ for (my $i=0; $i<@rstart-1; $i++) {
+ printf $out " {0x%04x, 0x%04x},\n", $rstart[$i], $rend[$i];
+ }
+ printf $out " {0x%04x, 0x%04x}\n", $rstart[@rstart-1], $rend[@rstart-1];
+ }
+ print $out "};\n\n";
+
+ # Print the C struct that contains the range list length and
+ # pointer to the range list.
+ print $out "scm_t_char_set cs_${f} = {\n";
+ print $out " $len,\n";
+ print $out " cs_" . $f . "_ranges\n";
+ print $out "};\n\n";
+}
+
+# Write a bit of a header
+print $out "/* srfi-14.i.c -- standard SRFI-14 character set data */\n\n";
+print $out "/* This file is #include'd by srfi-14.c. */\n\n";
+print $out "/* This file was generated from\n";
+print $out " http://unicode.org/Public/UNIDATA/UnicodeData.txt\n";
+print $out " with the unidata_to_charset.pl script. */\n\n";
+
+# Write the C structs for each SRFI-14 charset
+compute "lower_case";
+compute "upper_case";
+compute "title_case";
+compute "letter";
+compute "digit";
+compute "hex_digit";
+compute "letter_plus_digit";
+compute "graphic";
+compute "whitespace";
+compute "printing";
+compute "iso_control";
+compute "punctuation";
+compute "symbol";
+compute "blank";
+compute "ascii";
+compute "empty";
+compute "designated";
+
+close $in;
+close $out;
+
+exec ('indent srfi-14.i.c') or print STDERR "call to 'indent' failed: $!";
+
+# And we're done.
+
+
+
+
+
+
64, 128
};
-/* FIXME: return bit size instead of byte size? */
size_t
scm_array_handle_uniform_element_size (scm_t_array_handle *h)
{
size_t ret = scm_i_array_element_type_sizes[h->element_type];
if (ret && ret % 8 == 0)
return ret / 8;
+ else if (ret)
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "byte-aligned uniform array");
+ else
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
+}
+
+size_t
+scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h)
+{
+ size_t ret = scm_i_array_element_type_sizes[h->element_type];
+ if (ret)
+ return ret;
else
scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0,
(SCM v),
- "Return the number of elements in the uniform vector, @var{v}.")
+ "Return the type of the elements in the uniform vector, @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_element_type
{
scm_t_array_handle h;
- size_t len;
- ssize_t inc;
SCM ret;
- scm_uniform_vector_elements (v, &h, &len, &inc);
+
+ if (!scm_is_uniform_vector (v))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, v, "uniform vector");
+ scm_array_get_handle (v, &h);
ret = scm_array_handle_element_type (&h);
scm_array_handle_release (&h);
return ret;
SCM
scm_c_uniform_vector_ref (SCM v, size_t idx)
{
- SCM ret;
- scm_t_array_handle h;
- size_t len;
- ssize_t inc;
-
- scm_uniform_vector_elements (v, &h, &len, &inc);
- ret = scm_array_handle_ref (&h, idx*inc);
- scm_array_handle_release (&h);
- return ret;
+ if (!scm_is_uniform_vector (v))
+ scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
+ return scm_c_generalized_vector_ref (v, idx);
}
SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
void
scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
{
- scm_t_array_handle h;
- size_t len;
- ssize_t inc;
-
- scm_uniform_vector_elements (v, &h, &len, &inc);
- scm_array_handle_set (&h, idx*inc, val);
- scm_array_handle_release (&h);
+ if (!scm_is_uniform_vector (v))
+ scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
+ scm_c_generalized_vector_set_x (v, idx, val);
}
SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
"Convert the uniform numeric vector @var{uvec} to a list.")
#define FUNC_NAME s_scm_uniform_vector_to_list
{
- SCM ret;
- scm_t_array_handle h;
- size_t len;
- ssize_t inc;
-
- scm_uniform_vector_elements (uvec, &h, &len, &inc);
- ret = scm_generalized_vector_to_list (uvec);
- scm_array_handle_release (&h);
- return ret;
+ if (!scm_is_uniform_vector (uvec))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
+ return scm_generalized_vector_to_list (uvec);
}
#undef FUNC_NAME
#define SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED(t) \
(scm_i_array_element_type_sizes[(t)] != 0)
-/* returns type size in bits */
+/* type size in bytes */
SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h);
+/* type size in bits */
+SCM_API size_t scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h);
SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h);
SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h);
cvar = scm_to_bool (flag); \
} while (0)
-#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \
- SCM_VALIDATE_SMOB ((_pos), (_obj), bytevector)
+#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \
+ SCM_ASSERT_TYPE (SCM_BYTEVECTOR_P (_obj), (_obj), (_pos), \
+ FUNC_NAME, "bytevector")
#define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character")
#define SCM_VALIDATE_SMOB(pos, obj, type) \
do { \
- SCM_ASSERT (SCM_TYP16_PREDICATE (scm_tc16_ ## type, obj), \
+ SCM_ASSERT (SCM_SMOB_PREDICATE (scm_tc16_ ## type, obj), \
obj, pos, FUNC_NAME); \
} while (0)
#define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable")
-#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZEDP, "memoized code")
-
-#define SCM_VALIDATE_CLOSURE(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, CLOSUREP, "closure")
+#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZED_P, "memoized code")
#define SCM_VALIDATE_PROC(pos, proc) \
do { \
#define SCM_VALIDATE_VTABLE(pos, v) \
do { \
- SCM_ASSERT (!SCM_IMP (v) && scm_is_true (scm_struct_vtable_p (v)), \
- v, pos, FUNC_NAME); \
+ SCM_ASSERT (scm_is_true (scm_struct_vtable_p (v)), v, pos, FUNC_NAME); \
} while (0)
#define SCM_VALIDATE_VECTOR_LEN(pos, v, len) \
-/* Copyright (C) 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2000, 2001, 2006, 2008, 2009 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
void
scm_init_values (void)
{
- SCM print = scm_c_define_subr ("%print-values", scm_tc7_subr_2,
- print_values);
+ SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values);
- scm_values_vtable
- = scm_permanent_object (
- scm_make_vtable_vtable (scm_from_locale_string ("pr"),
- SCM_INUM0, SCM_EOL));
-
- SCM_SET_STRUCT_PRINTER (scm_values_vtable, print);
+ scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pr"), print);
scm_add_feature ("values");
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"
+#include "libguile/bdw-gc.h"
+
+
\f
#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
+ if (SCM_I_WVECTP (vec))
+ /* FIXME: We should check each (weak) element of the vector for NULL and
+ convert it to SCM_BOOL_F. */
+ abort ();
+
scm_generalized_vector_get_handle (vec, h);
if (lenp)
{
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
+ if (SCM_I_WVECTP (vec))
+ /* FIXME: We should check each (weak) element of the vector for NULL and
+ convert it to SCM_BOOL_F. */
+ abort ();
+
scm_generalized_vector_get_handle (vec, h);
if (lenp)
{
{
if (SCM_I_IS_VECTOR (v))
{
+ register SCM elt;
+
if (k >= SCM_I_VECTOR_LENGTH (v))
- scm_out_of_range (NULL, scm_from_size_t (k));
- return (SCM_I_VECTOR_ELTS(v))[k];
+ scm_out_of_range (NULL, scm_from_size_t (k));
+ elt = (SCM_I_VECTOR_ELTS(v))[k];
+
+ if ((elt == SCM_PACK (NULL)) && SCM_I_WVECTP (v))
+ /* ELT was a weak pointer and got nullified by the GC. */
+ return SCM_BOOL_F;
+
+ return elt;
}
else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
{
SCM vv = SCM_I_ARRAY_V (v);
if (SCM_I_IS_VECTOR (vv))
{
+ register SCM elt;
+
if (k >= dim->ubnd - dim->lbnd + 1)
scm_out_of_range (NULL, scm_from_size_t (k));
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
- return (SCM_I_VECTOR_ELTS (vv))[k];
+ elt = (SCM_I_VECTOR_ELTS (vv))[k];
+
+ if ((elt == SCM_PACK (NULL)) && (SCM_I_WVECTP (vv)))
+ /* ELT was a weak pointer and got nullified by the GC. */
+ return SCM_BOOL_F;
+
+ return elt;
}
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
}
if (k >= SCM_I_VECTOR_LENGTH (v))
scm_out_of_range (NULL, scm_from_size_t (k));
(SCM_I_VECTOR_WELTS(v))[k] = obj;
+ if (SCM_I_WVECTP (v))
+ {
+ /* Make it a weak pointer. */
+ GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
+ SCM_I_REGISTER_DISAPPEARING_LINK (link, obj);
+ }
}
else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
{
scm_out_of_range (NULL, scm_from_size_t (k));
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
(SCM_I_VECTOR_WELTS (vv))[k] = obj;
+
+ if (SCM_I_WVECTP (vv))
+ {
+ /* Make it a weak pointer. */
+ GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
+ SCM_I_REGISTER_DISAPPEARING_LINK (link, obj);
+ }
}
else
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
scm_c_make_vector (size_t k, SCM fill)
#define FUNC_NAME s_scm_make_vector
{
- SCM v;
- SCM *base;
+ SCM *vector;
- if (k > 0)
+ vector = (SCM *)
+ scm_gc_malloc ((k + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM),
+ "vector");
+
+ if (k > 0)
{
+ SCM *base;
unsigned long int j;
SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
- base = scm_gc_malloc (k * sizeof (SCM), "vector");
+ base = vector + SCM_I_VECTOR_HEADER_SIZE;
for (j = 0; j != k; ++j)
base[j] = fill;
}
- else
- base = NULL;
- v = scm_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base);
- scm_remember_upto_here_1 (fill);
+ ((scm_t_bits *) vector)[0] = (k << 8) | scm_tc7_vector;
+ ((scm_t_bits *) vector)[1] = 0;
- return v;
+ return PTR2SCM (vector);
}
#undef FUNC_NAME
size_t i, len;
ssize_t inc;
const SCM *src;
- SCM *dst;
+ SCM result, *dst;
src = scm_vector_elements (vec, &handle, &len, &inc);
- dst = scm_gc_malloc (len * sizeof (SCM), "vector");
+
+ result = scm_c_make_vector (len, SCM_UNDEFINED);
+ dst = SCM_I_VECTOR_WELTS (result);
for (i = 0; i < len; i++, src += inc)
dst[i] = *src;
+
scm_array_handle_release (&handle);
- return scm_cell ((len << 8) | scm_tc7_vector, (scm_t_bits) dst);
+ return result;
}
#undef FUNC_NAME
-void
-scm_i_vector_free (SCM vec)
+\f
+/* Weak vectors. */
+
+/* Allocate memory for the elements of a weak vector on behalf of the
+ caller. */
+static SCM
+make_weak_vector (scm_t_bits type, size_t c_size)
{
- scm_gc_free (SCM_I_VECTOR_WELTS (vec),
- SCM_I_VECTOR_LENGTH (vec) * sizeof(SCM),
- "vector");
+ SCM *vector;
+ size_t total_size;
+
+ total_size = (c_size + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM);
+ vector = (SCM *) scm_gc_malloc_pointerless (total_size, "weak vector");
+
+ ((scm_t_bits *) vector)[0] = (c_size << 8) | scm_tc7_wvect;
+ ((scm_t_bits *) vector)[1] = type;
+
+ return PTR2SCM (vector);
}
-/* Allocate memory for a weak vector on behalf of the caller. The allocated
- * vector will be of the given weak vector subtype. It will contain size
- * elements which are initialized with the 'fill' object, or, if 'fill' is
- * undefined, with an unspecified object.
- */
+/* Return a new weak vector. The allocated vector will be of the given weak
+ vector subtype. It will contain SIZE elements which are initialized with
+ the FILL object, or, if FILL is undefined, with an unspecified object. */
SCM
-scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill)
+scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill)
{
- size_t c_size;
- SCM *base;
- SCM v;
+ SCM wv, *base;
+ size_t c_size, j;
+
+ if (SCM_UNBNDP (fill))
+ fill = SCM_UNSPECIFIED;
c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
+ wv = make_weak_vector (type, c_size);
+ base = SCM_I_WVECT_GC_WVELTS (wv);
+
+ for (j = 0; j != c_size; ++j)
+ base[j] = fill;
- if (c_size > 0)
+ return wv;
+}
+
+/* Return a new weak vector with type TYPE and whose content are taken from
+ list LST. */
+SCM
+scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst)
+{
+ SCM wv, *elt;
+ long c_size;
+
+ c_size = scm_ilength (lst);
+ SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list");
+
+ wv = make_weak_vector(type, (size_t) c_size);
+
+ for (elt = SCM_I_WVECT_GC_WVELTS (wv);
+ scm_is_pair (lst);
+ lst = SCM_CDR (lst), elt++)
{
- size_t j;
-
- if (SCM_UNBNDP (fill))
- fill = SCM_UNSPECIFIED;
-
- base = scm_gc_malloc (c_size * sizeof (SCM), "weak vector");
- for (j = 0; j != c_size; ++j)
- base[j] = fill;
+ *elt = SCM_CAR (lst);
}
- else
- base = NULL;
-
- v = scm_double_cell ((c_size << 8) | scm_tc7_wvect,
- (scm_t_bits) base,
- type,
- SCM_UNPACK (SCM_EOL));
- scm_remember_upto_here_1 (fill);
- return v;
+ return wv;
}
+
+\f
SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
(SCM v),
"Return a newly allocated list composed of the elements of @var{v}.\n"
void
scm_init_vectors ()
{
- scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED);
-
#include "libguile/vectors.x"
}
#ifndef SCM_VECTORS_H
#define SCM_VECTORS_H
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008, 2009 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
#define SCM_SIMPLE_VECTOR_REF(x,idx) ((SCM_I_VECTOR_ELTS(x))[idx])
#define SCM_SIMPLE_VECTOR_SET(x,idx,val) ((SCM_I_VECTOR_WELTS(x))[idx]=(val))
+\f
/* Internals */
+/* Vectors have a 2-word header: 1 for the type tag, and 1 for the weak
+ vector extra data (see below.) */
+#define SCM_I_VECTOR_HEADER_SIZE 2U
+
#define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
-#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_CELL_WORD_1 (x))
-#define SCM_I_VECTOR_WELTS(x) ((SCM *) SCM_CELL_WORD_1 (x))
+#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x))
+#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, SCM_I_VECTOR_HEADER_SIZE))
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
-SCM_INTERNAL void scm_i_vector_free (SCM vec);
SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y);
/* Weak vectors share implementation details with ordinary vectors,
- but no one else should.
- */
+ but no one else should. */
#define SCM_I_WVECTP(x) (!SCM_IMP (x) && \
SCM_TYP7 (x) == scm_tc7_wvect)
#define SCM_I_WVECT_LENGTH SCM_I_VECTOR_LENGTH
#define SCM_I_WVECT_VELTS SCM_I_VECTOR_ELTS
#define SCM_I_WVECT_GC_WVELTS SCM_I_VECTOR_WELTS
-#define SCM_I_WVECT_EXTRA(x) (SCM_CELL_WORD_2 (x))
-#define SCM_I_SET_WVECT_EXTRA(x, t) (SCM_SET_CELL_WORD_2 ((x),(t)))
-#define SCM_I_WVECT_GC_CHAIN(x) (SCM_CELL_OBJECT_3 (x))
-#define SCM_I_SET_WVECT_GC_CHAIN(x, o) (SCM_SET_CELL_OBJECT_3 ((x), (o)))
+#define SCM_I_WVECT_EXTRA(x) (SCM_CELL_WORD_1 (x))
+#define SCM_I_SET_WVECT_EXTRA(x, t) (SCM_SET_CELL_WORD_1 ((x),(t)))
-SCM_INTERNAL SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill);
+SCM_INTERNAL SCM scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill);
+SCM_INTERNAL SCM scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst);
SCM_INTERNAL void scm_init_vectors (void);
"@end lisp")
#define FUNC_NAME s_scm_version
{
-
- char version_str[3 * 4 + 3];
-
-#if SCM_MAJOR_VERSION > 9999 \
- || SCM_MINOR_VERSION > 9999 \
- || SCM_MICRO_VERSION > 9999
-# error version string may overflow buffer
-#endif
- sprintf (version_str, "%d.%d.%d",
- SCM_MAJOR_VERSION,
- SCM_MINOR_VERSION,
- SCM_MICRO_VERSION);
- return scm_from_locale_string (version_str);
+ return scm_from_locale_string (PACKAGE_VERSION);
}
#undef FUNC_NAME
#define VM_USE_CLOCK 0 /* Bogoclock */
#define VM_CHECK_OBJECT 1 /* Check object table */
#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */
-#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#define VM_USE_HOOKS 1
#define VM_USE_CLOCK 1
#define VM_CHECK_OBJECT 1
#define VM_CHECK_FREE_VARIABLES 1
-#define VM_PUSH_DEBUG_FRAMES 1
#else
#error unknown debug engine VM_ENGINE
#endif
size_t free_vars_count = 0; /* length of FREE_VARS */
SCM *objects = NULL; /* constant objects */
size_t object_count = 0; /* length of OBJECTS */
- SCM *stack_base = vp->stack_base; /* stack base address */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
/* Internal variables */
static void **jump_table = NULL;
#endif
-#if VM_PUSH_DEBUG_FRAMES
- scm_t_debug_frame debug;
- scm_t_debug_info debug_vect_body;
- debug.status = SCM_VOIDFRAME;
-#endif
-
#ifdef HAVE_LABELS_AS_VALUES
if (SCM_UNLIKELY (!jump_table))
{
/* Boot program */
program = vm_make_boot_program (nargs);
-#if VM_PUSH_DEBUG_FRAMES
- debug.prev = scm_i_last_debug_frame ();
- debug.status = SCM_APPLYFRAME;
- debug.vect = &debug_vect_body;
- debug.vect[0].a.proc = program; /* the boot program */
- debug.vect[0].a.args = SCM_EOL;
- scm_i_set_last_debug_frame (&debug);
-#endif
-
/* Initial frame */
CACHE_REGISTER ();
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH ((SCM)ip); /* ra */
CACHE_PROGRAM ();
PUSH (program);
fp = sp + 1;
- INIT_FRAME ();
+ ip = bp->base;
/* MV-call frame, function & arguments */
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH (0); /* ra */
PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args;
vm_done:
SYNC_ALL ();
-#if VM_PUSH_DEBUG_FRAMES
- scm_i_set_last_debug_frame (debug.prev);
-#endif
return finish_args;
/* Errors */
finish_args = SCM_EOL;
goto vm_error;
+ vm_error_kwargs_length_not_even:
+ err_msg = scm_from_locale_string ("Bad keyword argument list: odd length");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_kwargs_invalid_keyword:
+ err_msg = scm_from_locale_string ("Bad keyword argument list: expected keyword");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_kwargs_unrecognized_keyword:
+ err_msg = scm_from_locale_string ("Bad keyword argument list: unrecognized keyword");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
vm_error_too_many_args:
err_msg = scm_from_locale_string ("VM: Too many arguments");
finish_args = scm_list_1 (scm_from_int (nargs));
vm_error_wrong_type_apply:
SYNC_ALL ();
- scm_error (scm_misc_error_key, FUNC_NAME, "Wrong type to apply: ~S",
- scm_list_1 (program), SCM_BOOL_F);
+ scm_error (scm_arg_type_key, FUNC_NAME, "Wrong type to apply: ~S",
+ scm_list_1 (program), scm_list_1 (program));
goto vm_error;
vm_error_stack_overflow:
err_msg = scm_from_locale_string ("VM: Bad wide string length: ~S");
goto vm_error;
-#if VM_CHECK_IP
+#ifdef VM_CHECK_IP
vm_error_invalid_address:
err_msg = scm_from_locale_string ("VM: Invalid program address");
finish_args = SCM_EOL;
#undef VM_USE_CLOCK
#undef VM_CHECK_OBJECT
#undef VM_CHECK_FREE_VARIABLE
-#undef VM_PUSH_DEBUG_FRAMES
/*
Local Variables:
ip = vp->ip; \
sp = vp->sp; \
fp = vp->fp; \
- stack_base = fp ? SCM_FRAME_UPPER_ADDRESS (fp) - 1 : vp->stack_base; \
}
#define SYNC_REGISTER() \
#if VM_USE_HOOKS
#define RUN_HOOK(h) \
{ \
- if (SCM_UNLIKELY (!SCM_FALSEP (vp->hooks[h])))\
+ if (SCM_UNLIKELY (scm_is_true (vp->hooks[h])))\
{ \
SYNC_REGISTER (); \
vm_dispatch_hook (vp, vp->hooks[h], hook_args); \
#endif
#define CHECK_OVERFLOW() \
- if (sp > stack_limit) \
+ if (sp >= stack_limit) \
goto vm_error_stack_overflow
#define CHECK_UNDERFLOW() \
- if (sp < stack_base) \
+ if (sp < SCM_FRAME_UPPER_ADDRESS (fp)) \
goto vm_error_stack_underflow;
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
#define FETCH() (*ip++)
#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
-#define FETCH_WIDTH(width) do { width=*ip++; } while (0)
#undef CLOCK
#if VM_USE_CLOCK
}
\f
-/*
- * Stack frame
- */
-
-#define INIT_ARGS() \
-{ \
- if (SCM_UNLIKELY (bp->nrest)) \
- { \
- int n = nargs - (bp->nargs - 1); \
- if (n < 0) \
- goto vm_error_wrong_num_args; \
- /* NB, can cause GC while setting up the \
- stack frame */ \
- POP_LIST (n); \
- } \
- else \
- { \
- if (SCM_UNLIKELY (nargs != bp->nargs)) \
- goto vm_error_wrong_num_args; \
- } \
-}
-
/* See frames.h for the layout of stack frames */
/* When this is called, bp points to the new program data,
and the arguments are already on the stack */
-#define INIT_FRAME() \
-{ \
- int i; \
- \
- /* New registers */ \
- sp += bp->nlocs; \
- CHECK_OVERFLOW (); \
- stack_base = sp; \
- ip = bp->base; \
- \
- /* Init local variables */ \
- for (i=bp->nlocs; i;) \
- sp[-(--i)] = SCM_UNDEFINED; \
-}
-
#define DROP_FRAME() \
{ \
sp -= 3; \
FETCH_LENGTH (len);
if (SCM_UNLIKELY (len % 4))
- { finish_args = scm_list_1 (scm_from_size_t (len));
+ {
+ finish_args = scm_list_1 (scm_from_size_t (len));
goto vm_error_bad_wide_string_length;
}
VM_DEFINE_FUNCTION (100, not, "not", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (SCM_FALSEP (x)));
+ RETURN (scm_from_bool (scm_is_false_or_nil (x)));
}
VM_DEFINE_FUNCTION (101, not_not, "not-not", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (!SCM_FALSEP (x)));
+ RETURN (scm_from_bool (!scm_is_false_or_nil (x)));
}
VM_DEFINE_FUNCTION (102, eq, "eq?", 2)
{
ARGS2 (x, y);
- RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
+ RETURN (scm_from_bool (scm_is_eq (x, y)));
}
VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2)
{
ARGS2 (x, y);
- RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
+ RETURN (scm_from_bool (!scm_is_eq (x, y)));
}
VM_DEFINE_FUNCTION (104, nullp, "null?", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (SCM_NULLP (x)));
+ RETURN (scm_from_bool (scm_is_null_or_nil (x)));
}
VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (!SCM_NULLP (x)));
+ RETURN (scm_from_bool (!scm_is_null_or_nil (x)));
}
VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
{
ARGS2 (x, y);
- if (SCM_EQ_P (x, y))
+ if (scm_is_eq (x, y))
RETURN (SCM_BOOL_T);
if (SCM_IMP (x) || SCM_IMP (y))
RETURN (SCM_BOOL_F);
VM_DEFINE_FUNCTION (107, equal, "equal?", 2)
{
ARGS2 (x, y);
- if (SCM_EQ_P (x, y))
+ if (scm_is_eq (x, y))
RETURN (SCM_BOOL_T);
if (SCM_IMP (x) || SCM_IMP (y))
RETURN (SCM_BOOL_F);
VM_DEFINE_FUNCTION (108, pairp, "pair?", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (SCM_CONSP (x)));
+ RETURN (scm_from_bool (scm_is_pair (x)));
}
VM_DEFINE_FUNCTION (109, listp, "list?", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (scm_ilength (x) >= 0));
+ RETURN (scm_from_bool (scm_ilength (x) >= 0));
}
\f
{ \
ARGS2 (x, y); \
if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
- RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y))); \
+ RETURN (scm_from_bool (SCM_I_INUM (x) crel SCM_I_INUM (y))); \
SYNC_REGISTER (); \
RETURN (srel (x, y)); \
}
RETURN (scm_modulo (x, y));
}
+VM_DEFINE_FUNCTION (170, ash, "ash", 2)
+{
+ ARGS2 (x, y);
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ {
+ if (SCM_I_INUM (y) < 0)
+ RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
+ else if ((SCM_I_INUM (x) << SCM_I_INUM (y)) >> SCM_I_INUM (y)
+ == SCM_I_INUM (x))
+ RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) << SCM_I_INUM (y)));
+ /* fall through */
+ }
+ SYNC_REGISTER ();
+ RETURN (scm_ash (x, y));
+}
+
+VM_DEFINE_FUNCTION (171, logand, "logand", 2)
+{
+ ARGS2 (x, y);
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) & SCM_I_INUM (y)));
+ SYNC_REGISTER ();
+ RETURN (scm_logand (x, y));
+}
+
+VM_DEFINE_FUNCTION (172, logior, "logior", 2)
+{
+ ARGS2 (x, y);
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) | SCM_I_INUM (y)));
+ SYNC_REGISTER ();
+ RETURN (scm_logior (x, y));
+}
+
+VM_DEFINE_FUNCTION (173, logxor, "logxor", 2)
+{
+ ARGS2 (x, y);
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
+ SYNC_REGISTER ();
+ RETURN (scm_logxor (x, y));
+}
+
\f
/*
* GOOPS support
*/
+VM_DEFINE_FUNCTION (169, class_of, "class-of", 1)
+{
+ ARGS1 (obj);
+ RETURN (SCM_INSTANCEP (obj) ? SCM_CLASS_OF (obj) : scm_class_of (obj));
+}
+
VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2)
{
size_t slot;
VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2)
-/* FIXME: u32 is always a fixnum on 64-bit builds */
+#if SIZEOF_VOID_P > 4
+BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
+#else
BV_INT_REF (u32, uint32, 4)
+#endif
VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2)
+#if SIZEOF_VOID_P > 4
+BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
+#else
BV_INT_REF (s32, int32, 4)
+#endif
VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2)
VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
-/* FIXME: u32 is always a fixnum on 64-bit builds */
+#if SIZEOF_VOID_P > 4
+BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
+#else
BV_INT_SET (u32, uint32, 4)
+#endif
VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+#if SIZEOF_VOID_P > 4
+BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
+#else
BV_INT_SET (s32, int32, 4)
+#endif
VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
}
{
- ASSERT (sp == stack_base);
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp = sp;
+#endif
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = NULL;
+ /* Setting the ip here doesn't actually affect control flow, as the calling
+ code will restore its own registers, but it does help when walking the
+ stack */
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- NULLSTACK (stack_base - sp);
+ NULLSTACK (old_sp - sp);
}
goto vm_done;
NEXT;
}
-VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (24, local_bound, "local-bound?", 1, 0, 1)
+{
+ if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED)
+ PUSH (SCM_BOOL_F);
+ else
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (25, long_local_bound, "long-local-bound?", 2, 0, 1)
+{
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ if (LOCAL_REF (i) == SCM_UNDEFINED)
+ PUSH (SCM_BOOL_F);
+ else
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (26, variable_ref, "variable-ref", 0, 1, 1)
{
SCM x = *sp;
NEXT;
}
-VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 0, 1)
+{
+ if (VARIABLE_BOUNDP (*sp))
+ *sp = SCM_BOOL_T;
+ else
+ *sp = SCM_BOOL_F;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
NEXT;
}
-VM_DEFINE_INSTRUCTION (26, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
SCM what;
unsigned int objnum = FETCH ();
/* set */
-VM_DEFINE_INSTRUCTION (27, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (28, long_local_set, "long-local-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
{
unsigned int i = FETCH ();
i <<= 8;
NEXT;
}
-VM_DEFINE_INSTRUCTION (29, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 2, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (30, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
NEXT;
}
-VM_DEFINE_INSTRUCTION (31, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
SCM what;
unsigned int objnum = FETCH ();
* branch and jump
*/
-/* offset must be a signed 16 bit int!!! */
+/* offset must be at least 24 bits wide, and signed */
#define FETCH_OFFSET(offset) \
{ \
- int h = FETCH (); \
- int l = FETCH (); \
- offset = (h << 8) + l; \
+ offset = FETCH () << 16; \
+ offset += FETCH () << 8; \
+ offset += FETCH (); \
+ offset -= (offset & (1<<23)) << 1; \
}
#define BR(p) \
{ \
- scm_t_int16 offset; \
+ scm_t_int32 offset; \
FETCH_OFFSET (offset); \
if (p) \
- ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); \
+ ip += offset; \
NULLSTACK (1); \
DROP (); \
NEXT; \
}
-VM_DEFINE_INSTRUCTION (32, br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br, "br", 3, 0, 0)
{
- scm_t_int16 offset;
+ scm_t_int32 offset;
FETCH_OFFSET (offset);
- ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);
+ ip += offset;
NEXT;
}
-VM_DEFINE_INSTRUCTION (33, br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 3, 0, 0)
{
- BR (!SCM_FALSEP (*sp));
+ BR (scm_is_true_and_not_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (34, br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 3, 0, 0)
{
- BR (SCM_FALSEP (*sp));
+ BR (scm_is_false_or_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (35, br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 3, 0, 0)
{
sp--; /* underflow? */
- BR (SCM_EQ_P (sp[0], sp[1]));
+ BR (scm_is_eq (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (36, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
{
sp--; /* underflow? */
- BR (!SCM_EQ_P (sp[0], sp[1]));
+ BR (!scm_is_eq (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (37, br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 3, 0, 0)
{
- BR (SCM_NULLP (*sp));
+ BR (scm_is_null_or_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (38, br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 3, 0, 0)
{
- BR (!SCM_NULLP (*sp));
+ BR (!scm_is_null_or_nil (*sp));
}
\f
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (39, new_frame, "new-frame", 0, 0, 3)
+VM_DEFINE_INSTRUCTION (42, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
+{
+ scm_t_ptrdiff n;
+ scm_t_int32 offset;
+ n = FETCH () << 8;
+ n += FETCH ();
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) != n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (43, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
+{
+ scm_t_ptrdiff n;
+ scm_t_int32 offset;
+ n = FETCH () << 8;
+ n += FETCH ();
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) < n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (44, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
+{
+ scm_t_ptrdiff n;
+ scm_t_int32 offset;
+
+ n = FETCH () << 8;
+ n += FETCH ();
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) > n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (45, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ if (sp - (fp - 1) != n)
+ goto vm_error_wrong_num_args;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (46, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ if (sp - (fp - 1) < n)
+ goto vm_error_wrong_num_args;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (47, bind_optionals, "bind-optionals", 2, -1, -1)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ while (sp - (fp - 1) < n)
+ PUSH (SCM_UNDEFINED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (48, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
+{
+ SCM *walk;
+ scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
+ nreq = FETCH () << 8;
+ nreq += FETCH ();
+ nreq_and_opt = FETCH () << 8;
+ nreq_and_opt += FETCH ();
+ ntotal = FETCH () << 8;
+ ntotal += FETCH ();
+
+ /* look in optionals for first keyword or last positional */
+ /* starting after the last required positional arg */
+ walk = fp + nreq;
+ while (/* while we have args */
+ walk <= sp
+ /* and we still have positionals to fill */
+ && walk - fp < nreq_and_opt
+ /* and we haven't reached a keyword yet */
+ && !scm_is_keyword (*walk))
+ /* bind this optional arg (by leaving it in place) */
+ walk++;
+ /* now shuffle up, from walk to ntotal */
+ {
+ scm_t_ptrdiff nshuf = sp - walk + 1, i;
+ sp = (fp - 1) + ntotal + nshuf;
+ CHECK_OVERFLOW ();
+ for (i = 0; i < nshuf; i++)
+ sp[-i] = walk[nshuf-i-1];
+ }
+ /* and fill optionals & keyword args with SCM_UNDEFINED */
+ while (walk <= (fp - 1) + ntotal)
+ *walk++ = SCM_UNDEFINED;
+
+ NEXT;
+}
+
+/* Flags that determine whether other keywords are allowed, and whether a
+ rest argument is expected. These values must match those used by the
+ glil->assembly compiler. */
+#define F_ALLOW_OTHER_KEYS 1
+#define F_REST 2
+
+VM_DEFINE_INSTRUCTION (49, bind_kwargs, "bind-kwargs", 5, 0, 0)
+{
+ scm_t_uint16 idx;
+ scm_t_ptrdiff nkw;
+ int kw_and_rest_flags;
+ SCM kw;
+ idx = FETCH () << 8;
+ idx += FETCH ();
+ /* XXX: We don't actually use NKW. */
+ nkw = FETCH () << 8;
+ nkw += FETCH ();
+ kw_and_rest_flags = FETCH ();
+
+ if (!(kw_and_rest_flags & F_REST)
+ && ((sp - (fp - 1) - nkw) % 2))
+ goto vm_error_kwargs_length_not_even;
+
+ CHECK_OBJECT (idx);
+ kw = OBJECT_REF (idx);
+
+ /* Switch NKW to be a negative index below SP. */
+ for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++)
+ {
+ SCM walk;
+
+ if (scm_is_keyword (sp[nkw]))
+ {
+ for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
+ {
+ if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
+ {
+ SCM si = SCM_CDAR (walk);
+ LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
+ sp[nkw + 1]);
+ break;
+ }
+ }
+ if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
+ goto vm_error_kwargs_unrecognized_keyword;
+
+ nkw++;
+ }
+ else if (!(kw_and_rest_flags & F_REST))
+ goto vm_error_kwargs_invalid_keyword;
+ }
+
+ NEXT;
+}
+
+#undef F_ALLOW_OTHER_KEYS
+#undef F_REST
+
+
+VM_DEFINE_INSTRUCTION (50, push_rest, "push-rest", 2, -1, -1)
+{
+ scm_t_ptrdiff n;
+ SCM rest = SCM_EOL;
+ n = FETCH () << 8;
+ n += FETCH ();
+ while (sp - (fp - 1) > n)
+ /* No need to check for underflow. */
+ CONS (rest, *sp--, rest);
+ PUSH (rest);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (51, bind_rest, "bind-rest", 4, -1, -1)
+{
+ scm_t_ptrdiff n;
+ scm_t_uint32 i;
+ SCM rest = SCM_EOL;
+ n = FETCH () << 8;
+ n += FETCH ();
+ i = FETCH () << 8;
+ i += FETCH ();
+ while (sp - (fp - 1) > n)
+ /* No need to check for underflow. */
+ CONS (rest, *sp--, rest);
+ LOCAL_SET (i, rest);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (52, reserve_locals, "reserve-locals", 2, -1, -1)
{
+ SCM *old_sp;
+ scm_t_int32 n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ old_sp = sp;
+ sp = (fp - 1) + n;
+
+ if (old_sp < sp)
+ {
+ CHECK_OVERFLOW ();
+ while (old_sp < sp)
+ *++old_sp = SCM_UNDEFINED;
+ }
+ else
+ NULLSTACK (old_sp - sp);
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (53, new_frame, "new-frame", 0, 0, 3)
+{
+ /* NB: if you change this, see frames.c:vm-frame-num-locals */
+ /* and frames.h, vm-engine.c, etc of course */
PUSH ((SCM)fp); /* dynamic link */
PUSH (0); /* mvra */
PUSH (0); /* ra */
NEXT;
}
-VM_DEFINE_INSTRUCTION (40, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
{
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
- fp = sp - bp->nargs + 1;
+ fp = sp - nargs + 1;
ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
+ {
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
+ goto vm_call;
+ }
/*
* Other interpreted or compiled call
*/
- if (!SCM_FALSEP (scm_procedure_p (x)))
+ if (!scm_is_false (scm_procedure_p (x)))
{
- SCM args;
+ SCM ret;
/* At this point, the stack contains the frame, the procedure and each one
of its arguments. */
- POP_LIST (nargs);
- POP (args);
- DROP (); /* drop the procedure */
- DROP_FRAME ();
-
SYNC_REGISTER ();
- PUSH (scm_apply (x, args, SCM_EOL));
+ ret = apply_foreign (sp[-nargs],
+ sp - nargs + 1,
+ nargs,
+ vp->stack_limit - sp + 1);
NULLSTACK_FOR_NONLOCAL_EXIT ();
- if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
+ DROPN (nargs + 1); /* drop args and procedure */
+ DROP_FRAME ();
+
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
{
/* truncate values */
- SCM values;
- POP (values);
- values = scm_struct_ref (values, SCM_INUM0);
- if (scm_is_null (values))
+ ret = scm_struct_ref (ret, SCM_INUM0);
+ if (scm_is_null (ret))
goto vm_error_not_enough_values;
- PUSH (SCM_CAR (values));
+ PUSH (SCM_CAR (ret));
}
+ else
+ PUSH (ret);
NEXT;
}
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (41, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (55, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
{
int i;
#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp;
+ SCM *old_sp = sp;
+ CHECK_STACK_LEAK ();
#endif
EXIT_HOOK ();
/* switch programs */
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
-
-#ifdef VM_ENABLE_STACK_NULLING
- old_sp = sp;
- CHECK_STACK_LEAK ();
-#endif
+ /* shuffle down the program and the arguments */
+ for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
+ SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
- /* delay shuffling the new program+args down so that if INIT_ARGS had to
- cons up a rest arg, going into GC, the stack still made sense */
- for (i = -1, sp = sp - bp->nargs + 1; i < bp->nargs; i++)
- fp[i] = sp[i];
sp = fp + i - 1;
NULLSTACK (old_sp - sp);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
-
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
+ {
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
+ goto vm_goto_args;
+ }
/*
* Other interpreted or compiled call
*/
- if (!SCM_FALSEP (scm_procedure_p (x)))
+ if (!scm_is_false (scm_procedure_p (x)))
{
- SCM args;
- POP_LIST (nargs);
- POP (args);
-
+ SCM ret;
SYNC_REGISTER ();
- *sp = scm_apply (x, args, SCM_EOL);
+ ret = apply_foreign (sp[-nargs],
+ sp - nargs + 1,
+ nargs,
+ vp->stack_limit - sp + 1);
NULLSTACK_FOR_NONLOCAL_EXIT ();
-
- if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
+ DROPN (nargs + 1); /* drop args and procedure */
+
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
{
/* multiple values returned to continuation */
- SCM values;
- POP (values);
- values = scm_struct_ref (values, SCM_INUM0);
- nvalues = scm_ilength (values);
- PUSH_LIST (values, SCM_NULLP);
+ ret = scm_struct_ref (ret, SCM_INUM0);
+ nvalues = scm_ilength (ret);
+ PUSH_LIST (ret, scm_is_null);
goto vm_return_values;
}
else
- goto vm_return;
+ {
+ PUSH (ret);
+ goto vm_return;
+ }
}
program = x;
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (42, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (56, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (43, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (44, mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
{
SCM x;
- scm_t_int16 offset;
+ scm_t_int32 offset;
scm_t_uint8 *mvra;
nargs = FETCH ();
FETCH_OFFSET (offset);
- mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8;
+ mvra = ip + offset;
+ vm_mv_call:
x = sp[-nargs];
/*
{
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
- fp = sp - bp->nargs + 1;
+ fp = sp - nargs + 1;
ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
+ {
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
+ goto vm_mv_call;
+ }
/*
* Other interpreted or compiled call
*/
- if (!SCM_FALSEP (scm_procedure_p (x)))
+ if (!scm_is_false (scm_procedure_p (x)))
{
- SCM args;
- /* At this point, the stack contains the procedure and each one of its
- arguments. */
- POP_LIST (nargs);
- POP (args);
- DROP (); /* drop the procedure */
- DROP_FRAME ();
-
+ SCM ret;
+ /* At this point, the stack contains the frame, the procedure and each one
+ of its arguments. */
SYNC_REGISTER ();
- PUSH (scm_apply (x, args, SCM_EOL));
+ ret = apply_foreign (sp[-nargs],
+ sp - nargs + 1,
+ nargs,
+ vp->stack_limit - sp + 1);
NULLSTACK_FOR_NONLOCAL_EXIT ();
- if (SCM_VALUESP (*sp))
+ DROPN (nargs + 1); /* drop args and procedure */
+ DROP_FRAME ();
+
+ if (SCM_VALUESP (ret))
{
- SCM values, len;
- POP (values);
- values = scm_struct_ref (values, SCM_INUM0);
- len = scm_length (values);
- PUSH_LIST (values, SCM_NULLP);
+ SCM len;
+ ret = scm_struct_ref (ret, SCM_INUM0);
+ len = scm_length (ret);
+ PUSH_LIST (ret, scm_is_null);
PUSH (len);
ip = mvra;
}
+ else
+ PUSH (ret);
NEXT;
}
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (45, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (46, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (60, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (47, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (61, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
/* multiple values returned to continuation */
SCM values;
values = scm_struct_ref (cont, SCM_INUM0);
- if (SCM_NULLP (values))
+ if (scm_is_null (values))
goto vm_error_no_values;
/* non-tail context does not accept multiple values? */
PUSH (SCM_CAR (values));
}
}
-VM_DEFINE_INSTRUCTION (48, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (62, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
SCM values;
values = scm_struct_ref (cont, SCM_INUM0);
nvalues = scm_ilength (values);
- PUSH_LIST (values, SCM_NULLP);
+ PUSH_LIST (values, scm_is_null);
goto vm_return_values;
}
else
}
}
-VM_DEFINE_INSTRUCTION (49, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
SCM ret;
POP (ret);
- ASSERT (sp == stack_base);
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp = sp;
+#endif
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- {
+
#ifdef VM_ENABLE_STACK_NULLING
- int nullcount = stack_base - sp;
+ NULLSTACK (old_sp - sp);
#endif
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
- NULLSTACK (nullcount);
- }
/* Set return value (sp is already pushed) */
*sp = ret;
NEXT;
}
-VM_DEFINE_INSTRUCTION (50, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (64, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say. */
EXIT_HOOK ();
RETURN_HOOK ();
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
-
- /* data[1] is the mv return address */
if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
{
+ /* A multiply-valued continuation */
+ SCM *vals = sp - nvalues;
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
- *++sp = stack_base[1+i];
+ *++sp = vals[i+1];
*++sp = SCM_I_MAKINUM (nvalues);
- /* Finally set new stack_base */
- NULLSTACK (stack_base - sp + nvalues + 1);
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ /* Finally null the end of the stack */
+ NULLSTACK (vals + nvalues - sp);
}
else if (nvalues >= 1)
{
break with guile tradition and try and do something sensible. (Also,
this block handles the single-valued return to an mv
continuation.) */
+ SCM *vals = sp - nvalues;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push first value */
- *++sp = stack_base[1];
+ *++sp = vals[1];
- /* Finally set new stack_base */
- NULLSTACK (stack_base - sp + nvalues + 1);
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ /* Finally null the end of the stack */
+ NULLSTACK (vals + nvalues - sp);
}
else
goto vm_error_no_values;
NEXT;
}
-VM_DEFINE_INSTRUCTION (51, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (65, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
nvalues--;
POP (l);
- while (SCM_CONSP (l))
+ while (scm_is_pair (l))
{
PUSH (SCM_CAR (l));
l = SCM_CDR (l);
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (52, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (66, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
NEXT;
}
-VM_DEFINE_INSTRUCTION (53, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (67, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (54, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (68, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
NEXT;
}
-VM_DEFINE_INSTRUCTION (55, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (69, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
NEXT;
}
-VM_DEFINE_INSTRUCTION (56, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (70, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
NEXT;
}
-VM_DEFINE_INSTRUCTION (57, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (71, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (58, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (72, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (59, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (73, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (60, make_closure, "make-closure", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (74, make_closure, "make-closure", 0, 2, 1)
{
SCM vect;
POP (vect);
NEXT;
}
-VM_DEFINE_INSTRUCTION (61, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (75, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
NEXT;
}
-VM_DEFINE_INSTRUCTION (62, fix_closure, "fix-closure", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (76, fix_closure, "fix-closure", 2, 0, 1)
{
SCM x, vect;
unsigned int i = FETCH ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (63, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (77, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (78, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (65, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (79, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
#include <stdlib.h>
#include <alloca.h>
#include <string.h>
+#include <assert.h>
+
+#include "libguile/bdw-gc.h"
+#include <gc/gc_mark.h>
+
#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
#define VM_ENABLE_ASSERTIONS
#endif
+/* When defined, arrange so that the GC doesn't scan the VM stack beyond its
+ current SP. This should help avoid excess data retention. See
+ http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
+ for a discussion. */
+#define VM_ENABLE_PRECISE_STACK_GC_SCAN
+
+
\f
/*
* VM Continuation
scm_t_bits scm_tc16_vm_cont;
-static void
-vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
-{
- SCM *sp, *mark;
- sp = base + size - 1;
-
- while (sp > base && fp)
- {
- mark = SCM_FRAME_LOWER_ADDRESS (fp) + 3;
-
- for (; sp >= mark; sp--)
- if (SCM_NIMP (*sp))
- {
- if (scm_in_heap_p (*sp))
- scm_gc_mark (*sp);
- /* this can happen for open frames */
- /* else fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp); */
- }
-
-
- /* skip ra, mvra */
- sp -= 2;
-
- /* update fp from the dynamic link */
- fp = (SCM*)*sp-- + reloc;
- }
-}
-
-static SCM
-vm_cont_mark (SCM obj)
-{
- struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
-
- if (p->stack_size)
- vm_mark_stack (p->stack_base, p->stack_size, p->fp + p->reloc, p->reloc);
-
- return SCM_BOOL_F;
-}
-
-static size_t
-vm_cont_free (SCM obj)
-{
- struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
-
- scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
- scm_gc_free (p, sizeof (*p), "vm-cont");
-
- return 0;
-}
-
static SCM
capture_vm_cont (struct scm_vm *vp)
{
static void
vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
{
- if (!SCM_FALSEP (vp->trace_frame))
+ if (!scm_is_false (vp->trace_frame))
return;
-
+
scm_dynwind_begin (0);
- // FIXME, stack holder should be the vm
- vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
+ /* FIXME, stack holder should be the vm */
+ vp->trace_frame = scm_c_make_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
scm_c_run_hook (hook, hook_args);
really_make_boot_program (long nargs)
{
SCM u8vec;
- scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
- scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
- scm_op_halt };
+ scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
+ scm_op_make_int8_1, scm_op_halt };
struct scm_objcode *bp;
SCM ret;
abort ();
text[1] = (scm_t_uint8)nargs;
- bp = scm_gc_malloc (sizeof (struct scm_objcode) + sizeof (text),
- "make-u8vector");
+ bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
memcpy (bp->base, text, sizeof (text));
- bp->nargs = 0;
- bp->nrest = 0;
- bp->nlocs = 0;
bp->len = sizeof(text);
bp->metalen = 0;
- bp->unused = 0;
u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
sizeof (struct scm_objcode) + sizeof (text));
ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
- SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
+ SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
return ret;
}
{
int i;
for (i = 0; i < NUM_BOOT_PROGS; i++)
- programs[i] = scm_permanent_object (really_make_boot_program (i));
+ programs[i] = really_make_boot_program (i);
}
if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
static SCM
resolve_variable (SCM what, SCM program_module)
{
- if (SCM_LIKELY (SCM_SYMBOLP (what)))
+ if (SCM_LIKELY (scm_is_symbol (what)))
{
if (SCM_LIKELY (scm_module_system_booted_p
&& scm_is_true (program_module)))
mod = scm_resolve_module (SCM_CAR (what));
if (scm_is_true (SCM_CADDR (what)))
mod = scm_module_public_interface (mod);
- if (SCM_FALSEP (mod))
+ if (scm_is_false (mod))
scm_misc_error (NULL, "no such module: ~S",
scm_list_1 (SCM_CAR (what)));
/* might longjmp */
}
}
+static SCM
+apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
+{
+ SCM_ASRTGO (SCM_NIMP (proc), badproc);
+
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badproc;
+ switch (nargs)
+ {
+ case 0:
+ return SCM_SMOB_APPLY_0 (proc);
+ case 1:
+ return SCM_SMOB_APPLY_1 (proc, args[0]);
+ case 2:
+ return SCM_SMOB_APPLY_2 (proc, args[0], args[1]);
+ default:
+ {
+ SCM arglist = SCM_EOL;
+ while (nargs-- > 2)
+ arglist = scm_cons (args[nargs], arglist);
+ return SCM_SMOB_APPLY_3 (proc, args[0], args[1], arglist);
+ }
+ }
+ case scm_tc7_gsubr:
+ return scm_i_gsubr_apply_array (proc, args, nargs, headroom);
+ default:
+ badproc:
+ scm_wrong_type_arg ("apply", SCM_ARG1, proc);
+ }
+}
+
#define VM_DEFAULT_STACK_SIZE (64 * 1024)
scm_t_bits scm_tc16_vm;
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+
+/* The GC "kind" for the VM stack. */
+static int vm_stack_gc_kind;
+
+#endif
+
static SCM
make_vm (void)
#define FUNC_NAME "make_vm"
{
int i;
+ struct scm_vm *vp;
if (!scm_tc16_vm)
return SCM_BOOL_F; /* not booted yet */
- struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+ vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
vp->stack_size = VM_DEFAULT_STACK_SIZE;
+
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+ vp->stack_base = GC_generic_malloc (vp->stack_size * sizeof (SCM),
+ vm_stack_gc_kind);
+
+ /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
+ top is. */
+ *vp->stack_base = PTR2SCM (vp);
+ vp->stack_base++;
+ vp->stack_size--;
+#else
vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
"stack-base");
+#endif
+
#ifdef VM_ENABLE_STACK_NULLING
memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
#endif
- vp->stack_limit = vp->stack_base + vp->stack_size - 3;
+ vp->stack_limit = vp->stack_base + vp->stack_size;
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->fp = NULL;
}
#undef FUNC_NAME
-static SCM
-vm_mark (SCM obj)
-{
- int i;
- struct scm_vm *vp = SCM_VM_DATA (obj);
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
-#ifdef VM_ENABLE_STACK_NULLING
- if (vp->sp >= vp->stack_base)
- if (!vp->sp[0] || vp->sp[1])
- abort ();
-#endif
+/* Mark the VM stack region between its base and its current top. */
+static struct GC_ms_entry *
+vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit, GC_word env)
+{
+ GC_word *word;
+ const struct scm_vm *vm;
- /* mark the stack, precisely */
- vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
+ /* The first word of the VM stack should contain a pointer to the
+ corresponding VM. */
+ vm = * ((struct scm_vm **) addr);
- /* mark other objects */
- for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
- scm_gc_mark (vp->hooks[i]);
+ if (vm == NULL
+ || (SCM *) addr != vm->stack_base - 1
+ || vm->stack_limit - vm->stack_base != vm->stack_size)
+ /* ADDR must be a pointer to a free-list element, which we must ignore
+ (see warning in <gc/gc_mark.h>). */
+ return mark_stack_ptr;
- scm_gc_mark (vp->trace_frame);
+ for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
+ mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
+ mark_stack_ptr, mark_stack_limit,
+ NULL);
- return vp->options;
+ return mark_stack_ptr;
}
-static size_t
-vm_free (SCM obj)
-{
- struct scm_vm *vp = SCM_VM_DATA (obj);
+#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
- scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
- "stack-base");
- scm_gc_free (vp, sizeof (struct scm_vm), "vm");
-
- return 0;
-}
SCM
scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
int i, nargs;
SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROGRAM (2, program);
+ SCM_VALIDATE_PROC (2, program);
nargs = scm_ilength (args);
if (SCM_UNLIKELY (nargs < 0))
}
#undef FUNC_NAME
+SCM
+scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
+{
+ return scm_c_vm_run (vm, thunk, NULL, 0);
+}
+
/* Scheme interface */
SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
- if (SCM_UNLIKELY (SCM_FALSEP ((t->vm))))
+ if (SCM_UNLIKELY (scm_is_false ((t->vm))))
t->vm = make_vm ();
return t->vm;
"")
#define FUNC_NAME s_scm_vm_p
{
- return SCM_BOOL (SCM_VM_P (obj));
+ return scm_from_bool (SCM_VM_P (obj));
}
#undef FUNC_NAME
struct scm_vm *vp; \
SCM_VALIDATE_VM (1, vm); \
vp = SCM_VM_DATA (vm); \
- if (SCM_FALSEP (vp->hooks[n])) \
+ if (scm_is_false (vp->hooks[n])) \
vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
return vp->hooks[n]; \
}
scm_bootstrap_programs ();
scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
- scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
- scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
scm_tc16_vm = scm_make_smob_type ("vm", 0);
- scm_set_smob_mark (scm_tc16_vm, vm_mark);
- scm_set_smob_free (scm_tc16_vm, vm_free);
scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
scm_c_define ("load-compiled",
scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
scm_load_compiled_with_vm));
- sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
- sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
- sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
+ sym_vm_run = scm_from_locale_symbol ("vm-run");
+ sym_vm_error = scm_from_locale_symbol ("vm-error");
+ sym_debug = scm_from_locale_symbol ("debug");
scm_c_register_extension ("libguile", "scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
strappage = 1;
+
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+ vm_stack_gc_kind =
+ GC_new_kind (GC_new_free_list (),
+ GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
+ 0, 1);
+
+#endif
}
void
SCM_API SCM scm_make_vm (void);
SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+SCM_API SCM scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id);
SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
SCM_API scm_t_bits scm_tc16_vm_cont;
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
+#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_SMOB_DATA_1 (CONT))
SCM_API SCM scm_vm_capture_continuations (void);
SCM_API void scm_vm_reinstate_continuations (SCM conts);
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009 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
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM ans;
+ scm_t_port *pt;
ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */
if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
return EOF;
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
- {
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- *pt->read_buf = SCM_CHAR (ans);
- pt->read_pos = pt->read_buf;
- pt->read_end = pt->read_buf + 1;
- return *pt->read_buf;
- }
+ pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->encoding == NULL)
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ *pt->read_buf = SCM_CHAR (ans);
+ pt->read_pos = pt->read_buf;
+ pt->read_end = pt->read_buf + 1;
+ return *pt->read_buf;
+ }
+ else
+ scm_ungetc (SCM_CHAR (ans), port);
+ return SCM_CHAR (ans);
}
{
scm_t_bits tc = scm_make_port_type ("soft", sf_fill_input, sf_write);
- scm_set_port_mark (tc, scm_markstream);
scm_set_port_flush (tc, sf_flush);
scm_set_port_close (tc, sf_close);
scm_set_port_input_waiting (tc, sf_input_waiting);
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009 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
#include "libguile/validate.h"
#include "libguile/weaks.h"
+#include "libguile/bdw-gc.h"
+#include <gc/gc_typed.h>
+
+
+\f
+/* Weak pairs for use in weak alist vectors and weak hash tables.
+
+ We have weal-car pairs, weak-cdr pairs, and doubly weak pairs. In weak
+ pairs, the weak component(s) are not scanned for pointers and are
+ registered as disapperaring links; therefore, the weak component may be
+ set to NULL by the garbage collector when no other reference to that word
+ exist. Thus, users should only access weak pairs via the
+ `SCM_WEAK_PAIR_C[AD]R ()' macros. See also `scm_fixup_weak_alist ()' in
+ `hashtab.c'. */
+
+/* Type descriptors for weak-c[ad]r pairs. */
+static GC_descr wcar_pair_descr, wcdr_pair_descr;
+
+
+SCM
+scm_weak_car_pair (SCM car, SCM cdr)
+{
+ scm_t_cell *cell;
+
+ cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
+ wcar_pair_descr);
+
+ cell->word_0 = car;
+ cell->word_1 = cdr;
+
+ if (SCM_NIMP (car))
+ {
+ /* Weak car cells make sense iff the car is non-immediate. */
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
+ (GC_PTR) SCM_UNPACK (car));
+ }
+
+ return (SCM_PACK (cell));
+}
+
+SCM
+scm_weak_cdr_pair (SCM car, SCM cdr)
+{
+ scm_t_cell *cell;
+
+ cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
+ wcdr_pair_descr);
+
+ cell->word_0 = car;
+ cell->word_1 = cdr;
+
+ if (SCM_NIMP (cdr))
+ {
+ /* Weak cdr cells make sense iff the cdr is non-immediate. */
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
+ (GC_PTR) SCM_UNPACK (cdr));
+ }
+
+ return (SCM_PACK (cell));
+}
+
+SCM
+scm_doubly_weak_pair (SCM car, SCM cdr)
+{
+ /* Doubly weak cells shall not be scanned at all for pointers. */
+ scm_t_cell *cell = (scm_t_cell *)scm_gc_malloc_pointerless (sizeof (*cell),
+ "weak cell");
+
+ cell->word_0 = car;
+ cell->word_1 = cdr;
+
+ if (SCM_NIMP (car))
+ {
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
+ (GC_PTR) SCM_UNPACK (car));
+ }
+ if (SCM_NIMP (cdr))
+ {
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
+ (GC_PTR) SCM_UNPACK (cdr));
+ }
+
+ return (SCM_PACK (cell));
+}
+
+
\f
/* 1. The current hash table implementation in hashtab.c uses weak alist
"empty list.")
#define FUNC_NAME s_scm_make_weak_vector
{
- return scm_i_allocate_weak_vector (0, size, fill);
+ return scm_i_make_weak_vector (0, size, fill);
}
#undef FUNC_NAME
"the same way @code{list->vector} would.")
#define FUNC_NAME s_scm_weak_vector
{
- scm_t_array_handle handle;
- SCM res, *data;
- long i;
-
- i = scm_ilength (l);
- SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
-
- res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED);
- data = scm_vector_writable_elements (res, &handle, NULL, NULL);
-
- while (scm_is_pair (l) && i > 0)
- {
- *data++ = SCM_CAR (l);
- l = SCM_CDR (l);
- i--;
- }
-
- scm_array_handle_release (&handle);
-
- return res;
+ return scm_i_make_weak_vector_from_list (0, l);
}
#undef FUNC_NAME
#undef FUNC_NAME
\f
+/* Weak alist vectors, i.e., vectors of alists.
+
+ The alist vector themselves are _not_ weak. The `car' (or `cdr', or both)
+ of the pairs within it are weak. See `hashtab.c' for details. */
+
+
+/* FIXME: We used to have two implementations of weak hash tables: the one in
+ here and the one in `hashtab.c'. The difference is that weak alist
+ vectors could be used as vectors while (weak) hash tables can't. We need
+ to unify that. */
SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
(SCM size),
"would modify regular hash tables. (@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_weak_key_alist_vector
{
- return scm_i_allocate_weak_vector
- (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
+ return scm_make_weak_key_hash_table (size);
}
#undef FUNC_NAME
"(@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_weak_value_alist_vector
{
- return scm_i_allocate_weak_vector
- (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
+ return scm_make_weak_value_hash_table (size);
}
#undef FUNC_NAME
"buckets. (@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
{
- return scm_i_allocate_weak_vector
- (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
+ return scm_make_doubly_weak_hash_table (size);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
-
-static SCM weak_vectors;
-
-void
-scm_i_init_weak_vectors_for_gc ()
-{
- weak_vectors = SCM_EOL;
-}
-void
-scm_i_mark_weak_vector (SCM w)
-{
- SCM_I_SET_WVECT_GC_CHAIN (w, weak_vectors);
- weak_vectors = w;
-}
-
-static int
-scm_i_mark_weak_vector_non_weaks (SCM w)
-{
- int again = 0;
-
- if (SCM_IS_WHVEC_ANY (w))
- {
- SCM *ptr;
- long n = SCM_I_WVECT_LENGTH (w);
- long j;
- int weak_keys = SCM_IS_WHVEC (w) || SCM_IS_WHVEC_B (w);
- int weak_values = SCM_IS_WHVEC_V (w) || SCM_IS_WHVEC_B (w);
-
- ptr = SCM_I_WVECT_GC_WVELTS (w);
-
- for (j = 0; j < n; ++j)
- {
- SCM alist, slow_alist;
- int slow_toggle = 0;
-
- /* We do not set the mark bits of the alist spine cells here
- since we do not want to ever create the situation where a
- marked cell references an unmarked cell (except in
- scm_gc_mark, where the referenced cells will be marked
- immediately). Thus, we can not use mark bits to stop us
- from looping indefinitely over a cyclic alist. Instead,
- we use the standard tortoise and hare trick to catch
- cycles. The fast walker does the work, and stops when it
- catches the slow walker to ensure that the whole cycle
- has been worked on.
- */
-
- alist = slow_alist = ptr[j];
-
- while (scm_is_pair (alist))
- {
- SCM elt = SCM_CAR (alist);
-
- if (UNMARKED_CELL_P (elt))
- {
- if (scm_is_pair (elt))
- {
- SCM key = SCM_CAR (elt);
- SCM value = SCM_CDR (elt);
-
- if (!((weak_keys && UNMARKED_CELL_P (key))
- || (weak_values && UNMARKED_CELL_P (value))))
- {
- /* The item should be kept. We need to mark it
- recursively.
- */
- scm_gc_mark (elt);
- again = 1;
- }
- }
- else
- {
- /* A non-pair cell element. This should not
- appear in a real alist, but when it does, we
- need to keep it.
- */
- scm_gc_mark (elt);
- again = 1;
- }
- }
-
- alist = SCM_CDR (alist);
-
- if (slow_toggle && scm_is_pair (slow_alist))
- {
- slow_alist = SCM_CDR (slow_alist);
- slow_toggle = !slow_toggle;
- if (scm_is_eq (slow_alist, alist))
- break;
- }
- }
- if (!scm_is_pair (alist))
- scm_gc_mark (alist);
- }
- }
-
- return again;
-}
-
-int
-scm_i_mark_weak_vectors_non_weaks ()
-{
- int again = 0;
- SCM w = weak_vectors;
- while (!scm_is_null (w))
- {
- if (scm_i_mark_weak_vector_non_weaks (w))
- again = 1;
- w = SCM_I_WVECT_GC_CHAIN (w);
- }
- return again;
-}
-
-static void
-scm_i_remove_weaks (SCM w)
-{
- SCM *ptr = SCM_I_WVECT_GC_WVELTS (w);
- size_t n = SCM_I_WVECT_LENGTH (w);
- size_t i;
-
- if (!SCM_IS_WHVEC_ANY (w))
- {
- for (i = 0; i < n; ++i)
- if (UNMARKED_CELL_P (ptr[i]))
- ptr[i] = SCM_BOOL_F;
- }
- else
- {
- size_t delta = 0;
-
- for (i = 0; i < n; ++i)
- {
- SCM alist, *fixup;
-
- fixup = ptr + i;
- alist = *fixup;
- while (scm_is_pair (alist) && !SCM_GC_MARK_P (alist))
- {
- if (UNMARKED_CELL_P (SCM_CAR (alist)))
- {
- *fixup = SCM_CDR (alist);
- delta++;
- }
- else
- {
- SCM_SET_GC_MARK (alist);
- fixup = SCM_CDRLOC (alist);
- }
- alist = *fixup;
- }
- }
-#if 0
- if (delta)
- fprintf (stderr, "vector %p, delta %d\n", w, delta);
-#endif
- SCM_I_SET_WVECT_DELTA (w, delta);
- }
-}
-
-void
-scm_i_remove_weaks_from_weak_vectors ()
-{
- SCM w = weak_vectors;
- while (!scm_is_null (w))
- {
- scm_i_remove_weaks (w);
- w = SCM_I_WVECT_GC_CHAIN (w);
- }
-}
\f
-
SCM
scm_init_weaks_builtins ()
{
return SCM_UNSPECIFIED;
}
+void
+scm_weaks_prehistory ()
+{
+ /* Initialize weak pairs. */
+ GC_word wcar_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
+ GC_word wcdr_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
+
+ /* In a weak-car pair, only the second word must be scanned for
+ pointers. */
+ GC_set_bit (wcar_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1));
+ wcar_pair_descr = GC_make_descriptor (wcar_pair_bitmap,
+ GC_WORD_LEN (scm_t_cell));
+
+ /* Conversely, in a weak-cdr pair, only the first word must be scanned for
+ pointers. */
+ GC_set_bit (wcdr_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0));
+ wcdr_pair_descr = GC_make_descriptor (wcdr_pair_bitmap,
+ GC_WORD_LEN (scm_t_cell));
+
+}
+
void
scm_init_weaks ()
{
#ifndef SCM_WEAKS_H
#define SCM_WEAKS_H
-/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009 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
#define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_KEY)
#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_VALUE)
-/* The DELTA field is used by the abstract hash tables. During GC,
- this field will be set to the number of items that have been
- dropped. The abstract hash table will then use it to update its
- item count. DELTA is unsigned.
-*/
-
-#define SCM_I_WVECT_DELTA(x) (SCM_I_WVECT_EXTRA(x) >> 3)
-#define SCM_I_SET_WVECT_DELTA(x,n) (SCM_I_SET_WVECT_EXTRA \
- ((x), ((SCM_I_WVECT_EXTRA (x) & 7) \
- | ((n) << 3))))
-
#define SCM_I_WVECT_TYPE(x) (SCM_I_WVECT_EXTRA(x) & 7)
#define SCM_I_SET_WVECT_TYPE(x,t) (SCM_I_SET_WVECT_EXTRA \
((x), (SCM_I_WVECT_EXTRA (x) & ~7) | (t)))
#define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0)
\f
+/* Weak pairs. */
+
+SCM_INTERNAL SCM scm_weak_car_pair (SCM car, SCM cdr);
+SCM_INTERNAL SCM scm_weak_cdr_pair (SCM car, SCM cdr);
+SCM_INTERNAL SCM scm_doubly_weak_pair (SCM car, SCM cdr);
+
+/* Testing the weak component(s) of a cell for reachability. */
+#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \
+ (SCM_CELL_OBJECT ((_cell), (_word)) == SCM_PACK (NULL))
+#define SCM_WEAK_PAIR_CAR_DELETED_P(_cell) \
+ (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0))
+#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \
+ (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 1))
+
+#define SCM_WEAK_PAIR_DELETED_P(_cell) \
+ ((SCM_WEAK_PAIR_CAR_DELETED_P (_cell)) \
+ || (SCM_WEAK_PAIR_CDR_DELETED_P (_cell)))
+
+/* Accessing the components of a weak cell. These return `SCM_UNDEFINED' if
+ the car/cdr has been collected. */
+#define SCM_WEAK_PAIR_WORD(_cell, _word) \
+ (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word)) \
+ ? SCM_UNDEFINED \
+ : SCM_CELL_OBJECT ((_cell), (_word)))
+#define SCM_WEAK_PAIR_CAR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 0))
+#define SCM_WEAK_PAIR_CDR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 1))
+
+
+\f
+/* Weak vectors and weak hash tables. */
SCM_API SCM scm_make_weak_vector (SCM k, SCM fill);
SCM_API SCM scm_weak_vector (SCM l);
SCM_API SCM scm_weak_value_alist_vector_p (SCM x);
SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x);
SCM_INTERNAL SCM scm_init_weaks_builtins (void);
+SCM_INTERNAL void scm_weaks_prehistory (void);
SCM_INTERNAL void scm_init_weaks (void);
SCM_INTERNAL void scm_i_init_weak_vectors_for_gc (void);
while (end > line && (*end == '\r' || *end == '\n'))
*end-- = '\0';
}
- while (end > line && isspace (*end))
+ while (end > line && isspace ((int) (*end)))
*end-- = '\0';
return end;
--- /dev/null
+# arpa_inet_h.m4 serial 5
+dnl Copyright (C) 2006, 2008 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl Written by Simon Josefsson and Bruno Haible
+
+AC_DEFUN([gl_HEADER_ARPA_INET],
+[
+ dnl Use AC_REQUIRE here, so that the default behavior below is expanded
+ dnl once only, before all statements that occur in other macros.
+ AC_REQUIRE([gl_ARPA_INET_H_DEFAULTS])
+
+ AC_CHECK_HEADERS_ONCE([arpa/inet.h])
+ if test $ac_cv_header_arpa_inet_h = yes; then
+ HAVE_ARPA_INET_H=1
+ else
+ ARPA_INET_H='arpa/inet.h'
+ HAVE_ARPA_INET_H=0
+ fi
+ AC_SUBST([HAVE_ARPA_INET_H])
+ dnl Execute this unconditionally, because ARPA_INET_H may be set by other
+ dnl modules, after this code is executed.
+ gl_CHECK_NEXT_HEADERS([arpa/inet.h])
+])
+
+dnl Unconditionally enables the replacement of <arpa/inet.h>.
+AC_DEFUN([gl_REPLACE_ARPA_INET_H],
+[
+ AC_REQUIRE([gl_ARPA_INET_H_DEFAULTS])
+ ARPA_INET_H='arpa/inet.h'
+])
+
+AC_DEFUN([gl_ARPA_INET_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_ARPA_INET_H_DEFAULTS])
+ GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_ARPA_INET_H_DEFAULTS],
+[
+ GNULIB_INET_NTOP=0; AC_SUBST([GNULIB_INET_NTOP])
+ GNULIB_INET_PTON=0; AC_SUBST([GNULIB_INET_PTON])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_DECL_INET_NTOP=1; AC_SUBST([HAVE_DECL_INET_NTOP])
+ HAVE_DECL_INET_PTON=1; AC_SUBST([HAVE_DECL_INET_PTON])
+ ARPA_INET_H=''; AC_SUBST([ARPA_INET_H])
+])
+++ /dev/null
-# canonicalize-lgpl.m4 serial 5
-dnl Copyright (C) 2003, 2006-2007, 2009 Free Software Foundation, Inc.
-dnl This file is free software; the Free Software Foundation
-dnl gives unlimited permission to copy and/or distribute it,
-dnl with or without modifications, as long as this notice is preserved.
-
-AC_DEFUN([gl_CANONICALIZE_LGPL],
-[
- dnl Do this replacement check manually because the file name is shorter
- dnl than the function name.
- AC_CHECK_DECLS_ONCE([canonicalize_file_name])
- AC_CHECK_FUNCS_ONCE([canonicalize_file_name])
- if test $ac_cv_func_canonicalize_file_name = no; then
- AC_LIBOBJ([canonicalize-lgpl])
- AC_DEFINE([realpath], [rpl_realpath],
- [Define to a replacement function name for realpath().])
- gl_PREREQ_CANONICALIZE_LGPL
- fi
-])
-
-# Like gl_CANONICALIZE_LGPL, except prepare for separate compilation
-# (no AC_LIBOBJ).
-AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE],
-[
- AC_CHECK_DECLS_ONCE([canonicalize_file_name])
- AC_CHECK_FUNCS_ONCE([canonicalize_file_name])
- gl_PREREQ_CANONICALIZE_LGPL
-])
-
-# Prerequisites of lib/canonicalize-lgpl.c.
-AC_DEFUN([gl_PREREQ_CANONICALIZE_LGPL],
-[
- AC_CHECK_HEADERS_ONCE([sys/param.h unistd.h])
- AC_CHECK_FUNCS_ONCE([getcwd readlink])
-])
--- /dev/null
+# canonicalize.m4 serial 16
+
+dnl Copyright (C) 2003-2007, 2009 Free Software Foundation, Inc.
+
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+# Provides canonicalize_file_name and canonicalize_filename_mode, but does
+# not provide or fix realpath.
+AC_DEFUN([gl_FUNC_CANONICALIZE_FILENAME_MODE],
+[
+ AC_LIBOBJ([canonicalize])
+
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+ AC_CHECK_FUNCS_ONCE([canonicalize_file_name])
+ AC_REQUIRE([gl_DOUBLE_SLASH_ROOT])
+ AC_REQUIRE([gl_FUNC_REALPATH_WORKS])
+ if test $ac_cv_func_canonicalize_file_name = no; then
+ HAVE_CANONICALIZE_FILE_NAME=0
+ elif test "$gl_cv_func_realpath_works" != yes; then
+ REPLACE_CANONICALIZE_FILE_NAME=1
+ fi
+])
+
+# Provides canonicalize_file_name and realpath.
+AC_DEFUN([gl_CANONICALIZE_LGPL],
+[
+ AC_REQUIRE([gl_CANONICALIZE_LGPL_SEPARATE])
+ if test $ac_cv_func_canonicalize_file_name = no; then
+ HAVE_CANONICALIZE_FILE_NAME=0
+ AC_LIBOBJ([canonicalize-lgpl])
+ if test $ac_cv_func_realpath = no; then
+ HAVE_REALPATH=0
+ elif test "$gl_cv_func_realpath_works" != yes; then
+ REPLACE_REALPATH=1
+ fi
+ elif test "$gl_cv_func_realpath_works" != yes; then
+ AC_LIBOBJ([canonicalize-lgpl])
+ REPLACE_REALPATH=1
+ REPLACE_CANONICALIZE_FILE_NAME=1
+ fi
+])
+
+# Like gl_CANONICALIZE_LGPL, except prepare for separate compilation
+# (no AC_LIBOBJ).
+AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE],
+[
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+ AC_CHECK_FUNCS_ONCE([canonicalize_file_name getcwd readlink])
+ AC_REQUIRE([gl_DOUBLE_SLASH_ROOT])
+ AC_REQUIRE([gl_FUNC_REALPATH_WORKS])
+ AC_CHECK_HEADERS_ONCE([sys/param.h])
+])
+
+# Check whether realpath works. Assume that if a platform has both
+# realpath and canonicalize_file_name, but the former is broken, then
+# so is the latter.
+AC_DEFUN([gl_FUNC_REALPATH_WORKS],
+[
+ AC_CHECK_FUNCS_ONCE([realpath])
+ AC_CACHE_CHECK([whether realpath works], [gl_cv_func_realpath_works], [
+ touch conftest.a
+ AC_RUN_IFELSE([
+ AC_LANG_PROGRAM([[
+ #include <stdlib.h>
+ ]], [[
+ char *name1 = realpath ("conftest.a", NULL);
+ char *name2 = realpath ("conftest.b/../conftest.a", NULL);
+ char *name3 = realpath ("conftest.a/", NULL);
+ return !(name1 && *name1 == '/' && !name2 && !name3);
+ ]])
+ ], [gl_cv_func_realpath_works=yes], [gl_cv_func_realpath_works=no],
+ [gl_cv_func_realpath_works="guessing no"])
+ ])
+ if test "$gl_cv_func_realpath_works" = yes; then
+ AC_DEFINE([FUNC_REALPATH_WORKS], [1], [Define to 1 if realpath()
+ can malloc memory, always gives an absolute path, and handles
+ trailing slash correctly.])
+ fi
+])
+++ /dev/null
-# count-one-bits.m4 serial 1
-dnl Copyright (C) 2007 Free Software Foundation, Inc.
-dnl This file is free software; the Free Software Foundation
-dnl gives unlimited permission to copy and/or distribute it,
-dnl with or without modifications, as long as this notice is preserved.
-
-AC_DEFUN([gl_COUNT_ONE_BITS],
-[
- dnl We don't need (and can't compile) count_one_bits_ll
- dnl unless the type 'unsigned long long int' exists.
- AC_REQUIRE([AC_TYPE_UNSIGNED_LONG_LONG_INT])
-])
--- /dev/null
+#serial 11 -*- autoconf -*-
+
+# Define some macros required for proper operation of code in lib/*.c
+# on MSDOS/Windows systems.
+
+# Copyright (C) 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# From Jim Meyering.
+
+AC_DEFUN([gl_AC_DOS],
+ [
+ AC_CACHE_CHECK([whether system is Windows or MSDOS], [ac_cv_win_or_dos],
+ [
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[
+#if !defined _WIN32 && !defined __WIN32__ && !defined __MSDOS__ && !defined __CYGWIN__
+neither MSDOS nor Windows
+#endif]])],
+ [ac_cv_win_or_dos=yes],
+ [ac_cv_win_or_dos=no])
+ ])
+
+ if test x"$ac_cv_win_or_dos" = xyes; then
+ ac_fs_accepts_drive_letter_prefix=1
+ ac_fs_backslash_is_file_name_separator=1
+ AC_CACHE_CHECK([whether drive letter can start relative path],
+ [ac_cv_drive_letter_can_be_relative],
+ [
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[
+#if defined __CYGWIN__
+drive letters are always absolute
+#endif]])],
+ [ac_cv_drive_letter_can_be_relative=yes],
+ [ac_cv_drive_letter_can_be_relative=no])
+ ])
+ if test x"$ac_cv_drive_letter_can_be_relative" = xyes; then
+ ac_fs_drive_letter_can_be_relative=1
+ else
+ ac_fs_drive_letter_can_be_relative=0
+ fi
+ else
+ ac_fs_accepts_drive_letter_prefix=0
+ ac_fs_backslash_is_file_name_separator=0
+ ac_fs_drive_letter_can_be_relative=0
+ fi
+
+ AC_DEFINE_UNQUOTED([FILE_SYSTEM_ACCEPTS_DRIVE_LETTER_PREFIX],
+ $ac_fs_accepts_drive_letter_prefix,
+ [Define on systems for which file names may have a so-called
+ `drive letter' prefix, define this to compute the length of that
+ prefix, including the colon.])
+
+ AH_VERBATIM(ISSLASH,
+ [#if FILE_SYSTEM_BACKSLASH_IS_FILE_NAME_SEPARATOR
+# define ISSLASH(C) ((C) == '/' || (C) == '\\')
+#else
+# define ISSLASH(C) ((C) == '/')
+#endif])
+
+ AC_DEFINE_UNQUOTED([FILE_SYSTEM_BACKSLASH_IS_FILE_NAME_SEPARATOR],
+ $ac_fs_backslash_is_file_name_separator,
+ [Define if the backslash character may also serve as a file name
+ component separator.])
+
+ AC_DEFINE_UNQUOTED([FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE],
+ $ac_fs_drive_letter_can_be_relative,
+ [Define if a drive letter prefix denotes a relative path if it is
+ not followed by a file name component separator.])
+ ])
--- /dev/null
+# double-slash-root.m4 serial 4 -*- Autoconf -*-
+dnl Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_DOUBLE_SLASH_ROOT],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_CACHE_CHECK([whether // is distinct from /], [gl_cv_double_slash_root],
+ [ if test x"$cross_compiling" = xyes ; then
+ # When cross-compiling, there is no way to tell whether // is special
+ # short of a list of hosts. However, the only known hosts to date
+ # that have a distinct // are Apollo DomainOS (too old to port to),
+ # Cygwin, and z/OS. If anyone knows of another system for which // has
+ # special semantics and is distinct from /, please report it to
+ # <bug-gnulib@gnu.org>.
+ case $host in
+ *-cygwin | i370-ibm-openedition)
+ gl_cv_double_slash_root=yes ;;
+ *)
+ # Be optimistic and assume that / and // are the same when we
+ # don't know.
+ gl_cv_double_slash_root='unknown, assuming no' ;;
+ esac
+ else
+ set x `ls -di / // 2>/dev/null`
+ if test "$[2]" = "$[4]" && wc //dev/null >/dev/null 2>&1; then
+ gl_cv_double_slash_root=no
+ else
+ gl_cv_double_slash_root=yes
+ fi
+ fi])
+ if test "$gl_cv_double_slash_root" = yes; then
+ AC_DEFINE([DOUBLE_SLASH_IS_DISTINCT_ROOT], [1],
+ [Define to 1 if // is a file system root distinct from /.])
+ fi
+])
--- /dev/null
+# duplocale.m4 serial 1
+dnl Copyright (C) 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_FUNC_DUPLOCALE],
+[
+ AC_REQUIRE([gl_LOCALE_H_DEFAULTS])
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_CHECK_FUNCS_ONCE([duplocale])
+ if test $ac_cv_func_duplocale = yes; then
+ dnl Check against glibc bug where duplocale crashes.
+ dnl See <http://sourceware.org/bugzilla/show_bug.cgi?id=10969>.
+ AC_REQUIRE([gl_LOCALE_H])
+ AC_CACHE_CHECK([whether duplocale(LC_GLOBAL_LOCALE) works],
+ [gl_cv_func_duplocale_works],
+ [AC_TRY_RUN([
+#include <locale.h>
+#if HAVE_XLOCALE_H
+# include <xlocale.h>
+#endif
+int main ()
+{
+ (void) duplocale (LC_GLOBAL_LOCALE);
+ return 0;
+}], [gl_cv_func_duplocale_works=yes], [gl_cv_func_duplocale_works=no],
+ [dnl Guess it works except on glibc < 2.12.
+ AC_EGREP_CPP([Unlucky GNU user], [
+#include <features.h>
+#ifdef __GNU_LIBRARY__
+ #if (__GLIBC__ == 2 && __GLIBC_MINOR__ < 12)
+ Unlucky GNU user
+ #endif
+#endif
+ ],
+ [gl_cv_func_duplocale_works="guessing no"],
+ [gl_cv_func_duplocale_works="guessing yes"])
+ ])
+ ])
+ case "$gl_cv_func_duplocale_works" in
+ *no) REPLACE_DUPLOCALE=1 ;;
+ esac
+ fi
+ if test $REPLACE_DUPLOCALE = 1; then
+ gl_REPLACE_LOCALE_H
+ AC_LIBOBJ([duplocale])
+ gl_PREREQ_DUPLOCALE
+ fi
+])
+
+# Prerequisites of lib/duplocale.c.
+AC_DEFUN([gl_PREREQ_DUPLOCALE],
+[
+ :
+])
-# environ.m4 serial 2
+# environ.m4 serial 3
dnl Copyright (C) 2001-2004, 2006-2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
-AC_DEFUN([gl_ENVIRON],
+AC_DEFUN_ONCE([gl_ENVIRON],
[
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
dnl Persuade glibc <unistd.h> to declare environ.
--- /dev/null
+# serial 6
+# Configure fcntl.h.
+dnl Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl Written by Paul Eggert.
+
+AC_DEFUN([gl_FCNTL_H],
+[
+ AC_REQUIRE([gl_FCNTL_H_DEFAULTS])
+ AC_REQUIRE([gl_FCNTL_O_FLAGS])
+ gl_CHECK_NEXT_HEADERS([fcntl.h])
+ FCNTL_H='fcntl.h'
+ AC_SUBST([FCNTL_H])
+])
+
+# Test whether the flags O_NOATIME and O_NOFOLLOW actually work.
+# Define HAVE_WORKING_O_NOATIME to 1 if O_NOATIME works, or to 0 otherwise.
+# Define HAVE_WORKING_O_NOFOLLOW to 1 if O_NOFOLLOW works, or to 0 otherwise.
+AC_DEFUN([gl_FCNTL_O_FLAGS],
+[
+ dnl Persuade glibc <fcntl.h> to define O_NOATIME and O_NOFOLLOW.
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+ AC_CACHE_CHECK([for working fcntl.h], [gl_cv_header_working_fcntl_h],
+ [AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <sys/types.h>
+ #include <sys/stat.h>
+ #include <unistd.h>
+ #include <fcntl.h>
+ #ifndef O_NOATIME
+ #define O_NOATIME 0
+ #endif
+ #ifndef O_NOFOLLOW
+ #define O_NOFOLLOW 0
+ #endif
+ static int const constants[] =
+ {
+ O_CREAT, O_EXCL, O_NOCTTY, O_TRUNC, O_APPEND,
+ O_NONBLOCK, O_SYNC, O_ACCMODE, O_RDONLY, O_RDWR, O_WRONLY
+ };
+ ]],
+ [[
+ int status = !constants;
+ {
+ static char const sym[] = "conftest.sym";
+ if (symlink (".", sym) != 0
+ || close (open (sym, O_RDONLY | O_NOFOLLOW)) == 0)
+ status |= 32;
+ unlink (sym);
+ }
+ {
+ static char const file[] = "confdefs.h";
+ int fd = open (file, O_RDONLY | O_NOATIME);
+ char c;
+ struct stat st0, st1;
+ if (fd < 0
+ || fstat (fd, &st0) != 0
+ || sleep (1) != 0
+ || read (fd, &c, 1) != 1
+ || close (fd) != 0
+ || stat (file, &st1) != 0
+ || st0.st_atime != st1.st_atime)
+ status |= 64;
+ }
+ return status;]])],
+ [gl_cv_header_working_fcntl_h=yes],
+ [case $? in #(
+ 32) gl_cv_header_working_fcntl_h='no (bad O_NOFOLLOW)';; #(
+ 64) gl_cv_header_working_fcntl_h='no (bad O_NOATIME)';; #(
+ 96) gl_cv_header_working_fcntl_h='no (bad O_NOATIME, O_NOFOLLOW)';; #(
+ *) gl_cv_header_working_fcntl_h='no';;
+ esac],
+ [gl_cv_header_working_fcntl_h=cross-compiling])])
+
+ case $gl_cv_header_working_fcntl_h in #(
+ *O_NOATIME* | no | cross-compiling) ac_val=0;; #(
+ *) ac_val=1;;
+ esac
+ AC_DEFINE_UNQUOTED([HAVE_WORKING_O_NOATIME], [$ac_val],
+ [Define to 1 if O_NOATIME works.])
+
+ case $gl_cv_header_working_fcntl_h in #(
+ *O_NOFOLLOW* | no | cross-compiling) ac_val=0;; #(
+ *) ac_val=1;;
+ esac
+ AC_DEFINE_UNQUOTED([HAVE_WORKING_O_NOFOLLOW], [$ac_val],
+ [Define to 1 if O_NOFOLLOW works.])
+])
+
+AC_DEFUN([gl_FCNTL_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_FCNTL_H_DEFAULTS])
+ GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_FCNTL_H_DEFAULTS],
+[
+ GNULIB_OPEN=0; AC_SUBST([GNULIB_OPEN])
+ GNULIB_OPENAT=0; AC_SUBST([GNULIB_OPENAT])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_OPENAT=1; AC_SUBST([HAVE_OPENAT])
+ REPLACE_OPEN=0; AC_SUBST([REPLACE_OPEN])
+ REPLACE_OPENAT=0; AC_SUBST([REPLACE_OPENAT])
+])
+++ /dev/null
-# getpagesize.m4 serial 7
-dnl Copyright (C) 2002, 2004-2005, 2007 Free Software Foundation, Inc.
-dnl This file is free software; the Free Software Foundation
-dnl gives unlimited permission to copy and/or distribute it,
-dnl with or without modifications, as long as this notice is preserved.
-
-AC_DEFUN([gl_FUNC_GETPAGESIZE],
-[
- AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
- AC_REQUIRE([AC_CANONICAL_HOST])
- AC_CHECK_FUNCS([getpagesize])
- if test $ac_cv_func_getpagesize = no; then
- HAVE_GETPAGESIZE=0
- AC_CHECK_HEADERS([OS.h])
- if test $ac_cv_header_OS_h = yes; then
- HAVE_OS_H=1
- fi
- AC_CHECK_HEADERS([sys/param.h])
- if test $ac_cv_header_sys_param_h = yes; then
- HAVE_SYS_PARAM_H=1
- fi
- fi
- case "$host_os" in
- mingw*)
- REPLACE_GETPAGESIZE=1
- AC_LIBOBJ([getpagesize])
- ;;
- esac
-])
# Specification in the form of a command-line invocation:
-# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-versions lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf
+# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --libtool --macro-prefix=gl --no-vc-files alignof alloca-opt announce-gen autobuild byteswap canonicalize-lgpl duplocale environ extensions flock fpieee full-read full-write gendocs gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton lib-symbol-versions lib-symbol-visibility libunistring locale maintainer-makefile putenv stdlib strcase strftime striconveh string verify version-etc-fsf vsnprintf warnings
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([])
gl_MODULES([
+ alignof
alloca-opt
+ announce-gen
autobuild
byteswap
canonicalize-lgpl
- count-one-bits
+ duplocale
environ
extensions
flock
fpieee
full-read
full-write
+ gendocs
+ gitlog-to-changelog
+ gnu-web-doc-update
+ gnupload
havelib
iconv_open-utf
+ inet_ntop
+ inet_pton
lib-symbol-versions
lib-symbol-visibility
libunistring
+ locale
+ maintainer-makefile
putenv
stdlib
strcase
striconveh
string
verify
+ version-etc-fsf
vsnprintf
+ warnings
])
gl_AVOID([])
gl_SOURCE_BASE([lib])
gl_DOC_BASE([doc])
gl_TESTS_BASE([tests])
gl_LIB([libgnu])
-gl_LGPL
+gl_LGPL([3])
gl_MAKEFILE_NAME([])
gl_LIBTOOL
gl_MACRO_PREFIX([gl])
AB_INIT
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
AC_REQUIRE([gl_FP_IEEE])
+ dnl Some compilers (e.g., AIX 5.3 cc) need to be in c99 mode
+ dnl for the builtin va_copy to work. With Autoconf 2.60 or later,
+ dnl AC_PROG_CC_STDC arranges for this. With older Autoconf AC_PROG_CC_STDC
+ dnl shouldn't hurt, though installers are on their own to set c99 mode.
+ AC_REQUIRE([AC_PROG_CC_STDC])
])
# This macro should be invoked from ./configure.ac, in the section
gl_COMMON
gl_source_base='lib'
gl_FUNC_ALLOCA
+ gl_HEADER_ARPA_INET
+ AC_PROG_MKDIR_P
gl_BYTESWAP
gl_CANONICALIZE_LGPL
gl_MODULE_INDICATOR([canonicalize-lgpl])
- gl_COUNT_ONE_BITS
+ gl_STDLIB_MODULE_INDICATOR([canonicalize_file_name])
+ gl_STDLIB_MODULE_INDICATOR([realpath])
+ gl_FUNC_DUPLOCALE
+ gl_LOCALE_MODULE_INDICATOR([duplocale])
gl_ENVIRON
gl_UNISTD_MODULE_INDICATOR([environ])
gl_HEADER_ERRNO_H
gl_FLOAT_H
gl_FUNC_FLOCK
gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock])
- gl_FUNC_GETPAGESIZE
- gl_UNISTD_MODULE_INDICATOR([getpagesize])
+ AC_SUBST([LIBINTL])
+ AC_SUBST([LTLIBINTL])
+ # Autoconf 2.61a.99 and earlier don't support linking a file only
+ # in VPATH builds. But since GNUmakefile is for maintainer use
+ # only, it does not matter if we skip the link with older autoconf.
+ # Automake 1.10.1 and earlier try to remove GNUmakefile in non-VPATH
+ # builds, so use a shell variable to bypass this.
+ GNUmakefile=GNUmakefile
+ m4_if(m4_version_compare([2.61a.100],
+ m4_defn([m4_PACKAGE_VERSION])), [1], [],
+ [AC_CONFIG_LINKS([$GNUmakefile:$GNUmakefile], [],
+ [GNUmakefile=$GNUmakefile])])
AM_ICONV
gl_ICONV_H
gl_FUNC_ICONV_OPEN
gl_FUNC_ICONV_OPEN_UTF
+ gl_INET_NTOP
+ gl_ARPA_INET_MODULE_INDICATOR([inet_ntop])
+ gl_INET_PTON
+ gl_ARPA_INET_MODULE_INDICATOR([inet_pton])
gl_INLINE
gl_LD_VERSION_SCRIPT
gl_VISIBILITY
gl_LOCALCHARSET
LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(top_builddir)/$gl_source_base\""
AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT])
+ gl_LOCALE_H
+ gl_FUNC_LSTAT
+ gl_SYS_STAT_MODULE_INDICATOR([lstat])
gl_FUNC_MALLOC_POSIX
gl_STDLIB_MODULE_INDICATOR([malloc-posix])
gl_MALLOCA
gl_FUNC_MEMCHR
gl_STRING_MODULE_INDICATOR([memchr])
gl_MULTIARCH
+ gl_HEADER_NETINET_IN
+ AC_PROG_MKDIR_P
gl_PATHMAX
gl_FUNC_PUTENV
gl_STDLIB_MODULE_INDICATOR([putenv])
gl_SAFE_READ
gl_SAFE_WRITE
gl_SIZE_MAX
+ gl_TYPE_SOCKLEN_T
gt_TYPE_SSIZE_T
+ gl_FUNC_STAT
+ gl_SYS_STAT_MODULE_INDICATOR([stat])
+ gl_STDARG_H
AM_STDBOOL_H
+ gl_STDDEF_H
gl_STDINT_H
gl_STDIO_H
gl_STDLIB_H
gl_HEADER_STRINGS_H
gl_HEADER_SYS_FILE_H
AC_PROG_MKDIR_P
+ gl_HEADER_SYS_SOCKET
+ AC_PROG_MKDIR_P
+ gl_HEADER_SYS_STAT_H
+ AC_PROG_MKDIR_P
gl_HEADER_TIME_H
gl_TIME_R
gl_UNISTD_H
gl_MODULE_INDICATOR([unistr/u8-mbtoucr])
gl_MODULE_INDICATOR([unistr/u8-uctomb])
gl_FUNC_VASNPRINTF
+ gl_VERSION_ETC
gl_FUNC_VSNPRINTF
gl_STDIO_MODULE_INDICATOR([vsnprintf])
+ AC_SUBST([WARN_CFLAGS])
gl_WCHAR_H
gl_FUNC_WRITE
gl_UNISTD_MODULE_INDICATOR([write])
# This macro records the list of files which have been installed by
# gnulib-tool and may be removed by future gnulib-tool invocations.
AC_DEFUN([gl_FILE_LIST], [
+ build-aux/announce-gen
build-aux/config.rpath
+ build-aux/gendocs.sh
+ build-aux/gitlog-to-changelog
+ build-aux/gnu-web-doc-update
+ build-aux/gnupload
build-aux/link-warning.h
+ build-aux/useless-if-before-free
+ build-aux/vc-list-files
+ doc/gendocs_template
+ lib/alignof.h
lib/alloca.in.h
+ lib/arpa_inet.in.h
lib/asnprintf.c
lib/byteswap.in.h
lib/c-ctype.c
lib/c-strcaseeq.h
lib/c-strncasecmp.c
lib/canonicalize-lgpl.c
- lib/canonicalize.h
lib/config.charset
- lib/count-one-bits.h
+ lib/duplocale.c
lib/errno.in.h
lib/float+.h
lib/float.in.h
lib/full-read.h
lib/full-write.c
lib/full-write.h
- lib/getpagesize.c
+ lib/gettext.h
lib/iconv.c
lib/iconv.in.h
lib/iconv_close.c
lib/iconv_open-hpux.gperf
lib/iconv_open-irix.gperf
lib/iconv_open-osf.gperf
+ lib/iconv_open-solaris.gperf
lib/iconv_open.c
lib/iconveh.h
+ lib/inet_ntop.c
+ lib/inet_pton.c
lib/localcharset.c
lib/localcharset.h
+ lib/locale.in.h
+ lib/lstat.c
lib/malloc.c
lib/malloca.c
lib/malloca.h
lib/mbsinit.c
lib/memchr.c
lib/memchr.valgrind
+ lib/netinet_in.in.h
lib/pathmax.h
lib/printf-args.c
lib/printf-args.h
lib/safe-write.c
lib/safe-write.h
lib/size_max.h
+ lib/stat.c
+ lib/stdarg.in.h
lib/stdbool.in.h
+ lib/stddef.in.h
lib/stdint.in.h
lib/stdio-write.c
lib/stdio.in.h
lib/strings.in.h
lib/strncasecmp.c
lib/sys_file.in.h
+ lib/sys_socket.in.h
+ lib/sys_stat.in.h
lib/time.in.h
lib/time_r.c
lib/unistd.in.h
lib/vasnprintf.c
lib/vasnprintf.h
lib/verify.h
+ lib/version-etc-fsf.c
+ lib/version-etc.c
+ lib/version-etc.h
lib/vsnprintf.c
lib/wchar.in.h
lib/write.c
lib/xsize.h
m4/00gnulib.m4
m4/alloca.m4
+ m4/arpa_inet_h.m4
m4/autobuild.m4
m4/byteswap.m4
- m4/canonicalize-lgpl.m4
+ m4/canonicalize.m4
m4/codeset.m4
- m4/count-one-bits.m4
+ m4/dos.m4
+ m4/double-slash-root.m4
+ m4/duplocale.m4
m4/eealloc.m4
m4/environ.m4
m4/errno_h.m4
m4/extensions.m4
+ m4/fcntl_h.m4
m4/float_h.m4
m4/flock.m4
m4/fpieee.m4
- m4/getpagesize.m4
m4/glibc21.m4
m4/gnulib-common.m4
m4/iconv.m4
m4/iconv_h.m4
m4/iconv_open.m4
m4/include_next.m4
+ m4/inet_ntop.m4
+ m4/inet_pton.m4
m4/inline.m4
m4/intmax_t.m4
m4/inttypes_h.m4
m4/locale-fr.m4
m4/locale-ja.m4
m4/locale-zh.m4
+ m4/locale_h.m4
m4/longlong.m4
+ m4/lstat.m4
m4/malloc.m4
m4/malloca.m4
m4/mbrlen.m4
m4/memchr.m4
m4/mmap-anon.m4
m4/multiarch.m4
+ m4/netinet_in_h.m4
m4/pathmax.m4
m4/printf.m4
m4/putenv.m4
m4/safe-read.m4
m4/safe-write.m4
m4/size_max.m4
+ m4/socklen.m4
+ m4/sockpfaf.m4
m4/ssize_t.m4
+ m4/stat.m4
+ m4/stdarg.m4
m4/stdbool.m4
+ m4/stddef_h.m4
m4/stdint.m4
m4/stdint_h.m4
m4/stdio_h.m4
m4/string_h.m4
m4/strings_h.m4
m4/sys_file_h.m4
+ m4/sys_socket_h.m4
+ m4/sys_stat_h.m4
m4/time_h.m4
m4/time_r.m4
m4/tm_gmtoff.m4
m4/unistd_h.m4
m4/vasnprintf.m4
+ m4/version-etc.m4
m4/visibility.m4
m4/vsnprintf.m4
+ m4/warnings.m4
m4/wchar.m4
m4/wchar_t.m4
m4/wint_t.m4
m4/write.m4
m4/xsize.m4
+ top/GNUmakefile
+ top/maint.mk
])
-# iconv_h.m4 serial 4
-dnl Copyright (C) 2007-2008 Free Software Foundation, Inc.
+# iconv_h.m4 serial 5
+dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
AC_DEFUN([gl_ICONV_H],
[
AC_REQUIRE([gl_ICONV_H_DEFAULTS])
+
+ dnl Execute this unconditionally, because ICONV_H may be set by other
+ dnl modules, after this code is executed.
gl_CHECK_NEXT_HEADERS([iconv.h])
])
-# iconv_open.m4 serial 5
+# iconv_open.m4 serial 6
dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
if test $gl_func_iconv_gnu = no; then
iconv_flavor=
case "$host_os" in
- aix*) iconv_flavor=ICONV_FLAVOR_AIX ;;
- irix*) iconv_flavor=ICONV_FLAVOR_IRIX ;;
- hpux*) iconv_flavor=ICONV_FLAVOR_HPUX ;;
- osf*) iconv_flavor=ICONV_FLAVOR_OSF ;;
+ aix*) iconv_flavor=ICONV_FLAVOR_AIX ;;
+ irix*) iconv_flavor=ICONV_FLAVOR_IRIX ;;
+ hpux*) iconv_flavor=ICONV_FLAVOR_HPUX ;;
+ osf*) iconv_flavor=ICONV_FLAVOR_OSF ;;
+ solaris*) iconv_flavor=ICONV_FLAVOR_SOLARIS ;;
esac
if test -n "$iconv_flavor"; then
AC_DEFINE_UNQUOTED([ICONV_FLAVOR], [$iconv_flavor],
--- /dev/null
+# inet_ntop.m4 serial 11
+dnl Copyright (C) 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_INET_NTOP],
+[
+ dnl Persuade Solaris <arpa/inet.h> to declare inet_ntop.
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+
+ gl_REPLACE_ARPA_INET_H
+
+ dnl Most platforms that provide inet_ntop define it in libc.
+ dnl Solaris 8..10 provide inet_ntop in libnsl instead.
+ gl_save_LIBS=$LIBS
+ AC_SEARCH_LIBS([inet_ntop], [nsl], [],
+ [AC_REPLACE_FUNCS([inet_ntop])])
+ LIBS=$gl_save_LIBS
+ INET_NTOP_LIB=
+ if test "$ac_cv_search_inet_ntop" != "no" &&
+ test "$ac_cv_search_inet_ntop" != "none required"; then
+ INET_NTOP_LIB="$ac_cv_search_inet_ntop"
+ fi
+ AC_SUBST([INET_NTOP_LIB])
+
+ gl_PREREQ_INET_NTOP
+])
+
+# Prerequisites of lib/inet_ntop.c.
+AC_DEFUN([gl_PREREQ_INET_NTOP], [
+ AC_CHECK_DECLS([inet_ntop],,,[#include <arpa/inet.h>])
+ if test $ac_cv_have_decl_inet_ntop = no; then
+ HAVE_DECL_INET_NTOP=0
+ fi
+ AC_REQUIRE([gl_SOCKET_FAMILIES])
+ AC_REQUIRE([AC_C_RESTRICT])
+])
--- /dev/null
+# inet_pton.m4 serial 9
+dnl Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_INET_PTON],
+[
+ dnl Persuade Solaris <arpa/inet.h> to declare inet_pton.
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+
+ gl_REPLACE_ARPA_INET_H
+
+ dnl Most platforms that provide inet_pton define it in libc.
+ dnl Solaris 8..10 provide inet_pton in libnsl instead.
+ gl_save_LIBS=$LIBS
+ AC_SEARCH_LIBS([inet_pton], [nsl], [],
+ [AC_REPLACE_FUNCS([inet_pton])])
+ LIBS=$gl_save_LIBS
+ INET_PTON_LIB=
+ if test "$ac_cv_search_inet_pton" != "no" &&
+ test "$ac_cv_search_inet_pton" != "none required"; then
+ INET_PTON_LIB="$ac_cv_search_inet_pton"
+ fi
+ AC_SUBST([INET_PTON_LIB])
+
+ gl_PREREQ_INET_PTON
+])
+
+# Prerequisites of lib/inet_pton.c.
+AC_DEFUN([gl_PREREQ_INET_PTON], [
+ AC_CHECK_DECLS([inet_pton],,,[#include <arpa/inet.h>])
+ if test $ac_cv_have_decl_inet_pton = no; then
+ HAVE_DECL_INET_PTON=0
+ fi
+ AC_REQUIRE([gl_SOCKET_FAMILIES])
+ AC_REQUIRE([AC_C_RESTRICT])
+])
-# localcharset.m4 serial 6
+# localcharset.m4 serial 7
dnl Copyright (C) 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
[
dnl Prerequisites of lib/localcharset.c.
AC_REQUIRE([AM_LANGINFO_CODESET])
+ AC_REQUIRE([gl_FCNTL_O_FLAGS])
AC_CHECK_DECLS_ONCE([getc_unlocked])
dnl Prerequisites of the lib/Makefile.am snippet.
--- /dev/null
+# locale_h.m4 serial 5
+dnl Copyright (C) 2007, 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_LOCALE_H],
+[
+ dnl Use AC_REQUIRE here, so that the default behavior below is expanded
+ dnl once only, before all statements that occur in other macros.
+ AC_REQUIRE([gl_LOCALE_H_DEFAULTS])
+
+ dnl Persuade glibc <locale.h> to define locale_t.
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+
+ dnl If <stddef.h> is replaced, then <locale.h> must also be replaced.
+ AC_REQUIRE([gl_STDDEF_H])
+
+ AC_CACHE_CHECK([whether locale.h conforms to POSIX:2001],
+ [gl_cv_header_locale_h_posix2001],
+ [AC_TRY_COMPILE([#include <locale.h>
+int x = LC_MESSAGES;], [],
+ [gl_cv_header_locale_h_posix2001=yes],
+ [gl_cv_header_locale_h_posix2001=no])])
+
+ dnl Check for <xlocale.h>.
+ AC_CHECK_HEADERS_ONCE([xlocale.h])
+ if test $ac_cv_header_xlocale_h = yes; then
+ HAVE_XLOCALE_H=1
+ dnl Check whether use of locale_t requires inclusion of <xlocale.h>,
+ dnl e.g. on MacOS X 10.5. If <locale.h> does not define locale_t by
+ dnl itself, we assume that <xlocale.h> will do so.
+ AC_CACHE_CHECK([whether locale.h defines locale_t],
+ [gl_cv_header_locale_has_locale_t],
+ [AC_TRY_COMPILE([#include <locale.h>
+locale_t x;], [],
+ [gl_cv_header_locale_has_locale_t=yes],
+ [gl_cv_header_locale_has_locale_t=no])
+ ])
+ if test $gl_cv_header_locale_has_locale_t = yes; then
+ gl_cv_header_locale_h_needs_xlocale_h=no
+ else
+ gl_cv_header_locale_h_needs_xlocale_h=yes
+ fi
+ else
+ HAVE_XLOCALE_H=0
+ gl_cv_header_locale_h_needs_xlocale_h=no
+ fi
+ AC_SUBST([HAVE_XLOCALE_H])
+
+ dnl Execute this unconditionally, because LOCALE_H may be set by other
+ dnl modules, after this code is executed.
+ gl_CHECK_NEXT_HEADERS([locale.h])
+
+ if test -n "$STDDEF_H" \
+ || test $gl_cv_header_locale_h_posix2001 = no \
+ || test $gl_cv_header_locale_h_needs_xlocale_h = yes; then
+ gl_REPLACE_LOCALE_H
+ fi
+])
+
+dnl Unconditionally enables the replacement of <locale.h>.
+AC_DEFUN([gl_REPLACE_LOCALE_H],
+[
+ AC_REQUIRE([gl_LOCALE_H_DEFAULTS])
+ LOCALE_H=locale.h
+])
+
+AC_DEFUN([gl_LOCALE_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_LOCALE_H_DEFAULTS])
+ GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_LOCALE_H_DEFAULTS],
+[
+ GNULIB_DUPLOCALE=0; AC_SUBST([GNULIB_DUPLOCALE])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ REPLACE_DUPLOCALE=0; AC_SUBST([REPLACE_DUPLOCALE])
+ LOCALE_H=''; AC_SUBST([LOCALE_H])
+])
--- /dev/null
+# serial 20
+
+# Copyright (C) 1997-2001, 2003-2009 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+dnl From Jim Meyering.
+
+AC_DEFUN([gl_FUNC_LSTAT],
+[
+ AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
+ dnl If lstat does not exist, the replacement <sys/stat.h> does
+ dnl "#define lstat stat", and lstat.c is a no-op.
+ AC_CHECK_FUNCS_ONCE([lstat])
+ if test $ac_cv_func_lstat = yes; then
+ AC_REQUIRE([AC_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
+ if test $ac_cv_func_lstat_dereferences_slashed_symlink = no; then
+ dnl Note: AC_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK does AC_LIBOBJ([lstat]).
+ REPLACE_LSTAT=1
+ fi
+ # Prerequisites of lib/lstat.c.
+ AC_REQUIRE([AC_C_INLINE])
+ else
+ HAVE_LSTAT=0
+ fi
+])
--- /dev/null
+# netinet_in_h.m4 serial 4
+dnl Copyright (C) 2006-2008 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_HEADER_NETINET_IN],
+[
+ AC_CACHE_CHECK([whether <netinet/in.h> is self-contained],
+ [gl_cv_header_netinet_in_h_selfcontained],
+ [
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <netinet/in.h>]], [[]])],
+ [gl_cv_header_netinet_in_h_selfcontained=yes],
+ [gl_cv_header_netinet_in_h_selfcontained=no])
+ ])
+ if test $gl_cv_header_netinet_in_h_selfcontained = yes; then
+ NETINET_IN_H=''
+ else
+ NETINET_IN_H='netinet/in.h'
+ AC_CHECK_HEADERS([netinet/in.h])
+ gl_CHECK_NEXT_HEADERS([netinet/in.h])
+ if test $ac_cv_header_netinet_in_h = yes; then
+ HAVE_NETINET_IN_H=1
+ else
+ HAVE_NETINET_IN_H=0
+ fi
+ AC_SUBST([HAVE_NETINET_IN_H])
+ fi
+ AC_SUBST([NETINET_IN_H])
+])
-# readlink.m4 serial 5
+# readlink.m4 serial 8
dnl Copyright (C) 2003, 2007, 2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
HAVE_READLINK=0
AC_LIBOBJ([readlink])
gl_PREREQ_READLINK
+ else
+ AC_CACHE_CHECK([whether readlink signature is correct],
+ [gl_cv_decl_readlink_works],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <unistd.h>
+ /* Cause compilation failure if original declaration has wrong type. */
+ ssize_t readlink (const char *, char *, size_t);]])],
+ [gl_cv_decl_readlink_works=yes], [gl_cv_decl_readlink_works=no])])
+ dnl Solaris 9 ignores trailing slash.
+ dnl FreeBSD 7.2 dereferences only one level of links with trailing slash.
+ AC_CACHE_CHECK([whether readlink handles trailing slash correctly],
+ [gl_cv_func_readlink_works],
+ [# We have readlink, so assume ln -s works.
+ ln -s conftest.no-such conftest.link
+ ln -s conftest.link conftest.lnk2
+ AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <unistd.h>
+]], [[char buf[20];
+ return readlink ("conftest.lnk2/", buf, sizeof buf) != -1;]])],
+ [gl_cv_func_readlink_works=yes], [gl_cv_func_readlink_works=no],
+ [gl_cv_func_readlink_works="guessing no"])
+ rm -f conftest.link])
+ if test "$gl_cv_func_readlink_works" != yes; then
+ AC_DEFINE([READLINK_TRAILING_SLASH_BUG], [1], [Define to 1 if readlink
+ fails to recognize a trailing slash.])
+ REPLACE_READLINK=1
+ AC_LIBOBJ([readlink])
+ elif test "$gl_cv_decl_readlink_works" != yes; then
+ REPLACE_READLINK=1
+ AC_LIBOBJ([readlink])
+ fi
fi
])
--- /dev/null
+# socklen.m4 serial 7
+dnl Copyright (C) 2005, 2006, 2007, 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Albert Chin, Windows fixes from Simon Josefsson.
+
+dnl Check for socklen_t: historically on BSD it is an int, and in
+dnl POSIX 1g it is a type of its own, but some platforms use different
+dnl types for the argument to getsockopt, getpeername, etc. So we
+dnl have to test to find something that will work.
+
+dnl On mingw32, socklen_t is in ws2tcpip.h ('int'), so we try to find
+dnl it there first. That file is included by gnulib's sys_socket.in.h, which
+dnl all users of this module should include. Cygwin must not include
+dnl ws2tcpip.h.
+AC_DEFUN([gl_TYPE_SOCKLEN_T],
+ [AC_REQUIRE([gl_HEADER_SYS_SOCKET])dnl
+ AC_CHECK_TYPE([socklen_t], ,
+ [AC_MSG_CHECKING([for socklen_t equivalent])
+ AC_CACHE_VAL([gl_cv_socklen_t_equiv],
+ [# Systems have either "struct sockaddr *" or
+ # "void *" as the second argument to getpeername
+ gl_cv_socklen_t_equiv=
+ for arg2 in "struct sockaddr" void; do
+ for t in int size_t "unsigned int" "long int" "unsigned long int"; do
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM(
+ [[#include <sys/types.h>
+ #include <sys/socket.h>
+
+ int getpeername (int, $arg2 *, $t *);]],
+ [[$t len;
+ getpeername (0, 0, &len);]])],
+ [gl_cv_socklen_t_equiv="$t"])
+ test "$gl_cv_socklen_t_equiv" != "" && break
+ done
+ test "$gl_cv_socklen_t_equiv" != "" && break
+ done
+ ])
+ if test "$gl_cv_socklen_t_equiv" = ""; then
+ AC_MSG_ERROR([Cannot find a type to use in place of socklen_t])
+ fi
+ AC_MSG_RESULT([$gl_cv_socklen_t_equiv])
+ AC_DEFINE_UNQUOTED([socklen_t], [$gl_cv_socklen_t_equiv],
+ [type to use in place of socklen_t if not defined])],
+ [#include <sys/types.h>
+ #if HAVE_SYS_SOCKET_H
+ # include <sys/socket.h>
+ #elif HAVE_WS2TCPIP_H
+ # include <ws2tcpip.h>
+ #endif])])
--- /dev/null
+# sockpfaf.m4 serial 7
+dnl Copyright (C) 2004, 2006, 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl Test for some common socket protocol families (PF_INET, PF_INET6, ...)
+dnl and some common address families (AF_INET, AF_INET6, ...).
+dnl This test assumes that a system supports an address family if and only if
+dnl it supports the corresponding protocol family.
+
+dnl From Bruno Haible.
+
+AC_DEFUN([gl_SOCKET_FAMILIES],
+[
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ AC_CHECK_HEADERS_ONCE([netinet/in.h])
+
+ AC_MSG_CHECKING([for IPv4 sockets])
+ AC_CACHE_VAL([gl_cv_socket_ipv4],
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+#ifdef HAVE_NETINET_IN_H
+#include <netinet/in.h>
+#endif
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#endif]],
+[[int x = AF_INET; struct in_addr y; struct sockaddr_in z;
+ if (&x && &y && &z) return 0;]])],
+ gl_cv_socket_ipv4=yes, gl_cv_socket_ipv4=no)])
+ AC_MSG_RESULT([$gl_cv_socket_ipv4])
+ if test $gl_cv_socket_ipv4 = yes; then
+ AC_DEFINE([HAVE_IPV4], [1], [Define to 1 if <sys/socket.h> defines AF_INET.])
+ fi
+
+ AC_MSG_CHECKING([for IPv6 sockets])
+ AC_CACHE_VAL([gl_cv_socket_ipv6],
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+#ifdef HAVE_NETINET_IN_H
+#include <netinet/in.h>
+#endif
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#endif]],
+[[int x = AF_INET6; struct in6_addr y; struct sockaddr_in6 z;
+ if (&x && &y && &z) return 0;]])],
+ gl_cv_socket_ipv6=yes, gl_cv_socket_ipv6=no)])
+ AC_MSG_RESULT([$gl_cv_socket_ipv6])
+ if test $gl_cv_socket_ipv6 = yes; then
+ AC_DEFINE([HAVE_IPV6], [1], [Define to 1 if <sys/socket.h> defines AF_INET6.])
+ fi
+])
--- /dev/null
+# serial 3
+
+# Copyright (C) 2009 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_FUNC_STAT],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_REQUIRE([gl_AC_DOS])
+ AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
+ AC_CHECK_FUNCS_ONCE([lstat])
+ dnl mingw is the only known platform where stat(".") and stat("./") differ
+ AC_CACHE_CHECK([whether stat handles trailing slashes on directories],
+ [gl_cv_func_stat_dir_slash],
+ [AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <sys/stat.h>
+]], [[struct stat st; return stat (".", &st) != stat ("./", &st);]])],
+ [gl_cv_func_stat_dir_slash=yes], [gl_cv_func_stat_dir_slash=no],
+ [case $host_os in
+ mingw*) gl_cv_func_stat_dir_slash="guessing no";;
+ *) gl_cv_func_stat_dir_slash="guessing yes";;
+ esac])])
+ dnl Solaris 9 mistakenly succeeds on stat("file/")
+ dnl FreeBSD 7.2 mistakenly succeeds on stat("link-to-file/")
+ AC_CACHE_CHECK([whether stat handles trailing slashes on files],
+ [gl_cv_func_stat_file_slash],
+ [touch conftest.tmp
+ # Assume that if we have lstat, we can also check symlinks.
+ if test $ac_cv_func_lstat = yes; then
+ ln -s conftest.tmp conftest.lnk
+ fi
+ AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <sys/stat.h>
+]], [[struct stat st;
+ if (!stat ("conftest.tmp/", &st)) return 1;
+#if HAVE_LSTAT
+ if (!stat ("conftest.lnk/", &st)) return 2;
+#endif
+ ]])],
+ [gl_cv_func_stat_file_slash=yes], [gl_cv_func_stat_file_slash=no],
+ [gl_cv_func_stat_file_slash="guessing no"])
+ rm -f conftest.tmp conftest.lnk])
+ case $gl_cv_func_stat_dir_slash in
+ *no) REPLACE_STAT=1
+ AC_DEFINE([REPLACE_FUNC_STAT_DIR], [1], [Define to 1 if stat needs
+ help when passed a directory name with a trailing slash]);;
+ esac
+ case $gl_cv_func_stat_file_slash in
+ *no) REPLACE_STAT=1
+ AC_DEFINE([REPLACE_FUNC_STAT_FILE], [1], [Define to 1 if stat needs
+ help when passed a file name with a trailing slash]);;
+ esac
+ if test $REPLACE_STAT = 1; then
+ AC_LIBOBJ([stat])
+ fi
+])
--- /dev/null
+# stdarg.m4 serial 3
+dnl Copyright (C) 2006, 2008-2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Bruno Haible.
+dnl Provide a working va_copy in combination with <stdarg.h>.
+
+AC_DEFUN([gl_STDARG_H],
+[
+ STDARG_H=''; AC_SUBST([STDARG_H])
+ NEXT_STDARG_H='<stdarg.h>'; AC_SUBST([NEXT_STDARG_H])
+ AC_MSG_CHECKING([for va_copy])
+ AC_CACHE_VAL([gl_cv_func_va_copy], [
+ AC_TRY_COMPILE([#include <stdarg.h>], [
+#ifndef va_copy
+void (*func) (va_list, va_list) = va_copy;
+#endif
+],
+ [gl_cv_func_va_copy=yes], [gl_cv_func_va_copy=no])])
+ AC_MSG_RESULT([$gl_cv_func_va_copy])
+ if test $gl_cv_func_va_copy = no; then
+ dnl Provide a substitute.
+ dnl Usually a simple definition in <config.h> is enough. Not so on AIX 5
+ dnl with some versions of the /usr/vac/bin/cc compiler. It has an <stdarg.h>
+ dnl which does '#undef va_copy', leading to a missing va_copy symbol. For
+ dnl this platform, we use an <stdarg.h> substitute. But we cannot use this
+ dnl approach on other platforms, because <stdarg.h> often defines only
+ dnl preprocessor macros and gl_ABSOLUTE_HEADER, gl_CHECK_NEXT_HEADERS do
+ dnl not work in this situation.
+ AC_EGREP_CPP([vaccine],
+ [#if defined _AIX && !defined __GNUC__
+ AIX vaccine
+ #endif
+ ], [gl_aixcc=yes], [gl_aixcc=no])
+ if test $gl_aixcc = yes; then
+ dnl Provide a substitute <stdarg.h> file.
+ STDARG_H=stdarg.h
+ gl_CHECK_NEXT_HEADERS([stdarg.h])
+ dnl Fallback for the case when <stdarg.h> contains only macro definitions.
+ if test "$gl_cv_next_stdarg_h" = '""'; then
+ gl_cv_next_stdarg_h='"///usr/include/stdarg.h"'
+ NEXT_STDARG_H="$gl_cv_next_stdarg_h"
+ fi
+ else
+ dnl Provide a substitute in <config.h>, either __va_copy or as a simple
+ dnl assignment.
+ gl_CACHE_VAL_SILENT([gl_cv_func___va_copy], [
+ AC_TRY_COMPILE([#include <stdarg.h>], [
+#ifndef __va_copy
+error, bail out
+#endif
+],
+ [gl_cv_func___va_copy=yes], [gl_cv_func___va_copy=no])])
+ if test $gl_cv_func___va_copy = yes; then
+ AC_DEFINE([va_copy], [__va_copy],
+ [Define as a macro for copying va_list variables.])
+ else
+ AH_VERBATIM([gl_VA_COPY], [/* A replacement for va_copy, if needed. */
+#define gl_va_copy(a,b) ((a) = (b))])
+ AC_DEFINE([va_copy], [gl_va_copy],
+ [Define as a macro for copying va_list variables.])
+ fi
+ fi
+ fi
+])
--- /dev/null
+dnl A placeholder for POSIX 2008 <stddef.h>, for platforms that have issues.
+# stddef_h.m4 serial 1
+dnl Copyright (C) 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_STDDEF_H],
+[
+ AC_REQUIRE([gl_STDDEF_H_DEFAULTS])
+ AC_REQUIRE([gt_TYPE_WCHAR_T])
+ if test $gt_cv_c_wchar_t = no; then
+ HAVE_WCHAR_T=0
+ STDDEF_H=stddef.h
+ fi
+ AC_CACHE_CHECK([whether NULL can be used in arbitrary expressions],
+ [gl_cv_decl_null_works],
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <stddef.h>
+ int test[2 * (sizeof NULL == sizeof (void *)) -1];
+]])],
+ [gl_cv_decl_null_works=yes],
+ [gl_cv_decl_null_works=no])])
+ if test $gl_cv_decl_null_works = no; then
+ REPLACE_NULL=1
+ STDDEF_H=stddef.h
+ fi
+ if test -n "$STDDEF_H"; then
+ gl_CHECK_NEXT_HEADERS([stddef.h])
+ fi
+])
+
+AC_DEFUN([gl_STDDEF_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_STDDEF_H_DEFAULTS])
+ GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_STDDEF_H_DEFAULTS],
+[
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ REPLACE_NULL=0; AC_SUBST([REPLACE_NULL])
+ HAVE_WCHAR_T=1; AC_SUBST([HAVE_WCHAR_T])
+ STDDEF_H=''; AC_SUBST([STDDEF_H])
+])
-# stdio_h.m4 serial 16
+# stdio_h.m4 serial 21
dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
AC_DEFUN([gl_STDIO_H_DEFAULTS],
[
- GNULIB_FPRINTF=0; AC_SUBST([GNULIB_FPRINTF])
- GNULIB_FPRINTF_POSIX=0; AC_SUBST([GNULIB_FPRINTF_POSIX])
- GNULIB_PRINTF=0; AC_SUBST([GNULIB_PRINTF])
- GNULIB_PRINTF_POSIX=0; AC_SUBST([GNULIB_PRINTF_POSIX])
- GNULIB_SNPRINTF=0; AC_SUBST([GNULIB_SNPRINTF])
- GNULIB_SPRINTF_POSIX=0; AC_SUBST([GNULIB_SPRINTF_POSIX])
- GNULIB_VFPRINTF=0; AC_SUBST([GNULIB_VFPRINTF])
- GNULIB_VFPRINTF_POSIX=0; AC_SUBST([GNULIB_VFPRINTF_POSIX])
- GNULIB_VPRINTF=0; AC_SUBST([GNULIB_VPRINTF])
- GNULIB_VPRINTF_POSIX=0; AC_SUBST([GNULIB_VPRINTF_POSIX])
- GNULIB_VSNPRINTF=0; AC_SUBST([GNULIB_VSNPRINTF])
- GNULIB_VSPRINTF_POSIX=0; AC_SUBST([GNULIB_VSPRINTF_POSIX])
GNULIB_DPRINTF=0; AC_SUBST([GNULIB_DPRINTF])
- GNULIB_VDPRINTF=0; AC_SUBST([GNULIB_VDPRINTF])
- GNULIB_VASPRINTF=0; AC_SUBST([GNULIB_VASPRINTF])
- GNULIB_OBSTACK_PRINTF=0; AC_SUBST([GNULIB_OBSTACK_PRINTF])
- GNULIB_OBSTACK_PRINTF_POSIX=0; AC_SUBST([GNULIB_OBSTACK_PRINTF_POSIX])
+ GNULIB_FCLOSE=0; AC_SUBST([GNULIB_FCLOSE])
+ GNULIB_FFLUSH=0; AC_SUBST([GNULIB_FFLUSH])
GNULIB_FOPEN=0; AC_SUBST([GNULIB_FOPEN])
+ GNULIB_FPRINTF=0; AC_SUBST([GNULIB_FPRINTF])
+ GNULIB_FPRINTF_POSIX=0; AC_SUBST([GNULIB_FPRINTF_POSIX])
+ GNULIB_FPURGE=0; AC_SUBST([GNULIB_FPURGE])
+ GNULIB_FPUTC=0; AC_SUBST([GNULIB_FPUTC])
+ GNULIB_FPUTS=0; AC_SUBST([GNULIB_FPUTS])
GNULIB_FREOPEN=0; AC_SUBST([GNULIB_FREOPEN])
GNULIB_FSEEK=0; AC_SUBST([GNULIB_FSEEK])
GNULIB_FSEEKO=0; AC_SUBST([GNULIB_FSEEKO])
GNULIB_FTELL=0; AC_SUBST([GNULIB_FTELL])
GNULIB_FTELLO=0; AC_SUBST([GNULIB_FTELLO])
- GNULIB_FFLUSH=0; AC_SUBST([GNULIB_FFLUSH])
- GNULIB_FPURGE=0; AC_SUBST([GNULIB_FPURGE])
- GNULIB_FCLOSE=0; AC_SUBST([GNULIB_FCLOSE])
- GNULIB_FPUTC=0; AC_SUBST([GNULIB_FPUTC])
- GNULIB_PUTC=0; AC_SUBST([GNULIB_PUTC])
- GNULIB_PUTCHAR=0; AC_SUBST([GNULIB_PUTCHAR])
- GNULIB_FPUTS=0; AC_SUBST([GNULIB_FPUTS])
- GNULIB_PUTS=0; AC_SUBST([GNULIB_PUTS])
GNULIB_FWRITE=0; AC_SUBST([GNULIB_FWRITE])
GNULIB_GETDELIM=0; AC_SUBST([GNULIB_GETDELIM])
GNULIB_GETLINE=0; AC_SUBST([GNULIB_GETLINE])
+ GNULIB_OBSTACK_PRINTF=0; AC_SUBST([GNULIB_OBSTACK_PRINTF])
+ GNULIB_OBSTACK_PRINTF_POSIX=0; AC_SUBST([GNULIB_OBSTACK_PRINTF_POSIX])
GNULIB_PERROR=0; AC_SUBST([GNULIB_PERROR])
+ GNULIB_POPEN=0; AC_SUBST([GNULIB_POPEN])
+ GNULIB_PRINTF=0; AC_SUBST([GNULIB_PRINTF])
+ GNULIB_PRINTF_POSIX=0; AC_SUBST([GNULIB_PRINTF_POSIX])
+ GNULIB_PUTC=0; AC_SUBST([GNULIB_PUTC])
+ GNULIB_PUTCHAR=0; AC_SUBST([GNULIB_PUTCHAR])
+ GNULIB_PUTS=0; AC_SUBST([GNULIB_PUTS])
+ GNULIB_REMOVE=0; AC_SUBST([GNULIB_REMOVE])
+ GNULIB_RENAME=0; AC_SUBST([GNULIB_RENAME])
+ GNULIB_RENAMEAT=0; AC_SUBST([GNULIB_RENAMEAT])
+ GNULIB_SNPRINTF=0; AC_SUBST([GNULIB_SNPRINTF])
+ GNULIB_SPRINTF_POSIX=0; AC_SUBST([GNULIB_SPRINTF_POSIX])
GNULIB_STDIO_H_SIGPIPE=0; AC_SUBST([GNULIB_STDIO_H_SIGPIPE])
+ GNULIB_VASPRINTF=0; AC_SUBST([GNULIB_VASPRINTF])
+ GNULIB_VDPRINTF=0; AC_SUBST([GNULIB_VDPRINTF])
+ GNULIB_VFPRINTF=0; AC_SUBST([GNULIB_VFPRINTF])
+ GNULIB_VFPRINTF_POSIX=0; AC_SUBST([GNULIB_VFPRINTF_POSIX])
+ GNULIB_VPRINTF=0; AC_SUBST([GNULIB_VPRINTF])
+ GNULIB_VPRINTF_POSIX=0; AC_SUBST([GNULIB_VPRINTF_POSIX])
+ GNULIB_VSNPRINTF=0; AC_SUBST([GNULIB_VSNPRINTF])
+ GNULIB_VSPRINTF_POSIX=0; AC_SUBST([GNULIB_VSPRINTF_POSIX])
dnl Assume proper GNU behavior unless another module says otherwise.
- REPLACE_STDIO_WRITE_FUNCS=0; AC_SUBST([REPLACE_STDIO_WRITE_FUNCS])
- REPLACE_FPRINTF=0; AC_SUBST([REPLACE_FPRINTF])
- REPLACE_VFPRINTF=0; AC_SUBST([REPLACE_VFPRINTF])
- REPLACE_PRINTF=0; AC_SUBST([REPLACE_PRINTF])
- REPLACE_VPRINTF=0; AC_SUBST([REPLACE_VPRINTF])
- REPLACE_SNPRINTF=0; AC_SUBST([REPLACE_SNPRINTF])
+ HAVE_DECL_FPURGE=1; AC_SUBST([HAVE_DECL_FPURGE])
+ HAVE_DECL_GETDELIM=1; AC_SUBST([HAVE_DECL_GETDELIM])
+ HAVE_DECL_GETLINE=1; AC_SUBST([HAVE_DECL_GETLINE])
+ HAVE_DECL_OBSTACK_PRINTF=1; AC_SUBST([HAVE_DECL_OBSTACK_PRINTF])
HAVE_DECL_SNPRINTF=1; AC_SUBST([HAVE_DECL_SNPRINTF])
- REPLACE_VSNPRINTF=0; AC_SUBST([REPLACE_VSNPRINTF])
HAVE_DECL_VSNPRINTF=1; AC_SUBST([HAVE_DECL_VSNPRINTF])
- REPLACE_SPRINTF=0; AC_SUBST([REPLACE_SPRINTF])
- REPLACE_VSPRINTF=0; AC_SUBST([REPLACE_VSPRINTF])
HAVE_DPRINTF=1; AC_SUBST([HAVE_DPRINTF])
- REPLACE_DPRINTF=0; AC_SUBST([REPLACE_DPRINTF])
- HAVE_VDPRINTF=1; AC_SUBST([HAVE_VDPRINTF])
- REPLACE_VDPRINTF=0; AC_SUBST([REPLACE_VDPRINTF])
+ HAVE_FSEEKO=1; AC_SUBST([HAVE_FSEEKO])
+ HAVE_FTELLO=1; AC_SUBST([HAVE_FTELLO])
+ HAVE_RENAMEAT=1; AC_SUBST([HAVE_RENAMEAT])
HAVE_VASPRINTF=1; AC_SUBST([HAVE_VASPRINTF])
- REPLACE_VASPRINTF=0; AC_SUBST([REPLACE_VASPRINTF])
- HAVE_DECL_OBSTACK_PRINTF=1; AC_SUBST([HAVE_DECL_OBSTACK_PRINTF])
- REPLACE_OBSTACK_PRINTF=0; AC_SUBST([REPLACE_OBSTACK_PRINTF])
+ HAVE_VDPRINTF=1; AC_SUBST([HAVE_VDPRINTF])
+ REPLACE_DPRINTF=0; AC_SUBST([REPLACE_DPRINTF])
+ REPLACE_FCLOSE=0; AC_SUBST([REPLACE_FCLOSE])
+ REPLACE_FFLUSH=0; AC_SUBST([REPLACE_FFLUSH])
REPLACE_FOPEN=0; AC_SUBST([REPLACE_FOPEN])
+ REPLACE_FPRINTF=0; AC_SUBST([REPLACE_FPRINTF])
+ REPLACE_FPURGE=0; AC_SUBST([REPLACE_FPURGE])
REPLACE_FREOPEN=0; AC_SUBST([REPLACE_FREOPEN])
- HAVE_FSEEKO=1; AC_SUBST([HAVE_FSEEKO])
- REPLACE_FSEEKO=0; AC_SUBST([REPLACE_FSEEKO])
REPLACE_FSEEK=0; AC_SUBST([REPLACE_FSEEK])
- HAVE_FTELLO=1; AC_SUBST([HAVE_FTELLO])
- REPLACE_FTELLO=0; AC_SUBST([REPLACE_FTELLO])
+ REPLACE_FSEEKO=0; AC_SUBST([REPLACE_FSEEKO])
REPLACE_FTELL=0; AC_SUBST([REPLACE_FTELL])
- REPLACE_FFLUSH=0; AC_SUBST([REPLACE_FFLUSH])
- REPLACE_FPURGE=0; AC_SUBST([REPLACE_FPURGE])
- HAVE_DECL_FPURGE=1; AC_SUBST([HAVE_DECL_FPURGE])
- REPLACE_FCLOSE=0; AC_SUBST([REPLACE_FCLOSE])
- HAVE_DECL_GETDELIM=1; AC_SUBST([HAVE_DECL_GETDELIM])
- HAVE_DECL_GETLINE=1; AC_SUBST([HAVE_DECL_GETLINE])
+ REPLACE_FTELLO=0; AC_SUBST([REPLACE_FTELLO])
REPLACE_GETLINE=0; AC_SUBST([REPLACE_GETLINE])
+ REPLACE_OBSTACK_PRINTF=0; AC_SUBST([REPLACE_OBSTACK_PRINTF])
REPLACE_PERROR=0; AC_SUBST([REPLACE_PERROR])
+ REPLACE_POPEN=0; AC_SUBST([REPLACE_POPEN])
+ REPLACE_PRINTF=0; AC_SUBST([REPLACE_PRINTF])
+ REPLACE_REMOVE=0; AC_SUBST([REPLACE_REMOVE])
+ REPLACE_RENAME=0; AC_SUBST([REPLACE_RENAME])
+ REPLACE_RENAMEAT=0; AC_SUBST([REPLACE_RENAMEAT])
+ REPLACE_SNPRINTF=0; AC_SUBST([REPLACE_SNPRINTF])
+ REPLACE_SPRINTF=0; AC_SUBST([REPLACE_SPRINTF])
+ REPLACE_STDIO_WRITE_FUNCS=0; AC_SUBST([REPLACE_STDIO_WRITE_FUNCS])
+ REPLACE_VASPRINTF=0; AC_SUBST([REPLACE_VASPRINTF])
+ REPLACE_VDPRINTF=0; AC_SUBST([REPLACE_VDPRINTF])
+ REPLACE_VFPRINTF=0; AC_SUBST([REPLACE_VFPRINTF])
+ REPLACE_VPRINTF=0; AC_SUBST([REPLACE_VPRINTF])
+ REPLACE_VSNPRINTF=0; AC_SUBST([REPLACE_VSNPRINTF])
+ REPLACE_VSPRINTF=0; AC_SUBST([REPLACE_VSPRINTF])
])
dnl Code shared by fseeko and ftello. Determine if large files are supported,
-# stdlib_h.m4 serial 15
+# stdlib_h.m4 serial 21
dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
AC_DEFUN([gl_STDLIB_H_DEFAULTS],
[
- GNULIB_MALLOC_POSIX=0; AC_SUBST([GNULIB_MALLOC_POSIX])
- GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX])
- GNULIB_CALLOC_POSIX=0; AC_SUBST([GNULIB_CALLOC_POSIX])
GNULIB_ATOLL=0; AC_SUBST([GNULIB_ATOLL])
+ GNULIB_CALLOC_POSIX=0; AC_SUBST([GNULIB_CALLOC_POSIX])
+ GNULIB_CANONICALIZE_FILE_NAME=0; AC_SUBST([GNULIB_CANONICALIZE_FILE_NAME])
GNULIB_GETLOADAVG=0; AC_SUBST([GNULIB_GETLOADAVG])
GNULIB_GETSUBOPT=0; AC_SUBST([GNULIB_GETSUBOPT])
+ GNULIB_MALLOC_POSIX=0; AC_SUBST([GNULIB_MALLOC_POSIX])
GNULIB_MKDTEMP=0; AC_SUBST([GNULIB_MKDTEMP])
+ GNULIB_MKOSTEMP=0; AC_SUBST([GNULIB_MKOSTEMP])
+ GNULIB_MKOSTEMPS=0; AC_SUBST([GNULIB_MKOSTEMPS])
GNULIB_MKSTEMP=0; AC_SUBST([GNULIB_MKSTEMP])
+ GNULIB_MKSTEMPS=0; AC_SUBST([GNULIB_MKSTEMPS])
GNULIB_PUTENV=0; AC_SUBST([GNULIB_PUTENV])
GNULIB_RANDOM_R=0; AC_SUBST([GNULIB_RANDOM_R])
+ GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX])
+ GNULIB_REALPATH=0; AC_SUBST([GNULIB_REALPATH])
GNULIB_RPMATCH=0; AC_SUBST([GNULIB_RPMATCH])
GNULIB_SETENV=0; AC_SUBST([GNULIB_SETENV])
GNULIB_STRTOD=0; AC_SUBST([GNULIB_STRTOD])
dnl Assume proper GNU behavior unless another module says otherwise.
HAVE_ATOLL=1; AC_SUBST([HAVE_ATOLL])
HAVE_CALLOC_POSIX=1; AC_SUBST([HAVE_CALLOC_POSIX])
+ HAVE_CANONICALIZE_FILE_NAME=1; AC_SUBST([HAVE_CANONICALIZE_FILE_NAME])
+ HAVE_DECL_GETLOADAVG=1; AC_SUBST([HAVE_DECL_GETLOADAVG])
HAVE_GETSUBOPT=1; AC_SUBST([HAVE_GETSUBOPT])
HAVE_MALLOC_POSIX=1; AC_SUBST([HAVE_MALLOC_POSIX])
HAVE_MKDTEMP=1; AC_SUBST([HAVE_MKDTEMP])
- HAVE_REALLOC_POSIX=1; AC_SUBST([HAVE_REALLOC_POSIX])
+ HAVE_MKOSTEMP=1; AC_SUBST([HAVE_MKOSTEMP])
+ HAVE_MKOSTEMPS=1; AC_SUBST([HAVE_MKOSTEMPS])
+ HAVE_MKSTEMPS=1; AC_SUBST([HAVE_MKSTEMPS])
HAVE_RANDOM_R=1; AC_SUBST([HAVE_RANDOM_R])
+ HAVE_REALLOC_POSIX=1; AC_SUBST([HAVE_REALLOC_POSIX])
+ HAVE_REALPATH=1; AC_SUBST([HAVE_REALPATH])
HAVE_RPMATCH=1; AC_SUBST([HAVE_RPMATCH])
HAVE_SETENV=1; AC_SUBST([HAVE_SETENV])
HAVE_STRTOD=1; AC_SUBST([HAVE_STRTOD])
HAVE_STRUCT_RANDOM_DATA=1; AC_SUBST([HAVE_STRUCT_RANDOM_DATA])
HAVE_SYS_LOADAVG_H=0; AC_SUBST([HAVE_SYS_LOADAVG_H])
HAVE_UNSETENV=1; AC_SUBST([HAVE_UNSETENV])
- HAVE_DECL_GETLOADAVG=1; AC_SUBST([HAVE_DECL_GETLOADAVG])
+ REPLACE_CANONICALIZE_FILE_NAME=0; AC_SUBST([REPLACE_CANONICALIZE_FILE_NAME])
REPLACE_MKSTEMP=0; AC_SUBST([REPLACE_MKSTEMP])
REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV])
+ REPLACE_REALPATH=0; AC_SUBST([REPLACE_REALPATH])
+ REPLACE_SETENV=0; AC_SUBST([REPLACE_SETENV])
REPLACE_STRTOD=0; AC_SUBST([REPLACE_STRTOD])
- VOID_UNSETENV=0; AC_SUBST([VOID_UNSETENV])
+ REPLACE_UNSETENV=0; AC_SUBST([REPLACE_UNSETENV])
])
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
-# serial 7
+# serial 9
# Written by Paul Eggert.
HAVE_STPNCPY=1; AC_SUBST([HAVE_STPNCPY])
HAVE_STRCHRNUL=1; AC_SUBST([HAVE_STRCHRNUL])
HAVE_DECL_STRDUP=1; AC_SUBST([HAVE_DECL_STRDUP])
- HAVE_STRNDUP=1; AC_SUBST([HAVE_STRNDUP])
HAVE_DECL_STRNDUP=1; AC_SUBST([HAVE_DECL_STRNDUP])
HAVE_DECL_STRNLEN=1; AC_SUBST([HAVE_DECL_STRNLEN])
HAVE_STRPBRK=1; AC_SUBST([HAVE_STRPBRK])
REPLACE_STRSTR=0; AC_SUBST([REPLACE_STRSTR])
REPLACE_STRCASESTR=0; AC_SUBST([REPLACE_STRCASESTR])
REPLACE_STRERROR=0; AC_SUBST([REPLACE_STRERROR])
+ REPLACE_STRNDUP=0; AC_SUBST([REPLACE_STRNDUP])
REPLACE_STRSIGNAL=0; AC_SUBST([REPLACE_STRSIGNAL])
+ REPLACE_STRTOK_R=0; AC_SUBST([REPLACE_STRTOK_R])
+ UNDEFINE_STRTOK_R=0; AC_SUBST([UNDEFINE_STRTOK_R])
])
--- /dev/null
+# sys_socket_h.m4 serial 13
+dnl Copyright (C) 2005-2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Simon Josefsson.
+
+AC_DEFUN([gl_HEADER_SYS_SOCKET],
+[
+ AC_REQUIRE([gl_SYS_SOCKET_H_DEFAULTS])
+ AC_REQUIRE([AC_C_INLINE])
+
+ AC_CACHE_CHECK([whether <sys/socket.h> is self-contained],
+ [gl_cv_header_sys_socket_h_selfcontained],
+ [
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/socket.h>]], [[]])],
+ [gl_cv_header_sys_socket_h_selfcontained=yes],
+ [gl_cv_header_sys_socket_h_selfcontained=no])
+ ])
+ if test $gl_cv_header_sys_socket_h_selfcontained = yes; then
+ SYS_SOCKET_H=''
+ dnl If the shutdown function exists, <sys/socket.h> should define
+ dnl SHUT_RD, SHUT_WR, SHUT_RDWR.
+ AC_CHECK_FUNCS([shutdown])
+ if test $ac_cv_func_shutdown = yes; then
+ AC_CACHE_CHECK([whether <sys/socket.h> defines the SHUT_* macros],
+ [gl_cv_header_sys_socket_h_shut],
+ [
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[#include <sys/socket.h>]],
+ [[int a[] = { SHUT_RD, SHUT_WR, SHUT_RDWR };]])],
+ [gl_cv_header_sys_socket_h_shut=yes],
+ [gl_cv_header_sys_socket_h_shut=no])
+ ])
+ if test $gl_cv_header_sys_socket_h_shut = no; then
+ SYS_SOCKET_H='sys/socket.h'
+ fi
+ fi
+ else
+ SYS_SOCKET_H='sys/socket.h'
+ fi
+ # We need to check for ws2tcpip.h now.
+ gl_PREREQ_SYS_H_SOCKET
+ AC_CHECK_TYPES([struct sockaddr_storage, sa_family_t],,,[
+ /* sys/types.h is not needed according to POSIX, but the
+ sys/socket.h in i386-unknown-freebsd4.10 and
+ powerpc-apple-darwin5.5 required it. */
+#include <sys/types.h>
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+#ifdef HAVE_WS2TCPIP_H
+#include <ws2tcpip.h>
+#endif
+])
+ if test $ac_cv_type_struct_sockaddr_storage = no; then
+ HAVE_STRUCT_SOCKADDR_STORAGE=0
+ SYS_SOCKET_H='sys/socket.h'
+ fi
+ if test $ac_cv_type_sa_family_t = no; then
+ HAVE_SA_FAMILY_T=0
+ SYS_SOCKET_H='sys/socket.h'
+ fi
+ if test -n "$SYS_SOCKET_H"; then
+ gl_PREREQ_SYS_H_WINSOCK2
+ fi
+ AC_SUBST([SYS_SOCKET_H])
+])
+
+AC_DEFUN([gl_PREREQ_SYS_H_SOCKET],
+[
+ dnl Check prerequisites of the <sys/socket.h> replacement.
+ gl_CHECK_NEXT_HEADERS([sys/socket.h])
+ if test $ac_cv_header_sys_socket_h = yes; then
+ HAVE_SYS_SOCKET_H=1
+ HAVE_WS2TCPIP_H=0
+ else
+ HAVE_SYS_SOCKET_H=0
+ dnl We cannot use AC_CHECK_HEADERS_ONCE here, because that would make
+ dnl the check for those headers unconditional; yet cygwin reports
+ dnl that the headers are present but cannot be compiled (since on
+ dnl cygwin, all socket information should come from sys/socket.h).
+ AC_CHECK_HEADERS([ws2tcpip.h])
+ if test $ac_cv_header_ws2tcpip_h = yes; then
+ HAVE_WS2TCPIP_H=1
+ else
+ HAVE_WS2TCPIP_H=0
+ fi
+ fi
+ AC_SUBST([HAVE_SYS_SOCKET_H])
+ AC_SUBST([HAVE_WS2TCPIP_H])
+])
+
+# Common prerequisites of the <sys/socket.h> replacement and of the
+# <sys/select.h> replacement.
+# Sets and substitutes HAVE_WINSOCK2_H.
+AC_DEFUN([gl_PREREQ_SYS_H_WINSOCK2],
+[
+ m4_ifdef([gl_UNISTD_H_DEFAULTS], [AC_REQUIRE([gl_UNISTD_H_DEFAULTS])])
+ m4_ifdef([gl_SYS_IOCTL_H_DEFAULTS], [AC_REQUIRE([gl_SYS_IOCTL_H_DEFAULTS])])
+ AC_CHECK_HEADERS_ONCE([sys/socket.h])
+ if test $ac_cv_header_sys_socket_h != yes; then
+ dnl We cannot use AC_CHECK_HEADERS_ONCE here, because that would make
+ dnl the check for those headers unconditional; yet cygwin reports
+ dnl that the headers are present but cannot be compiled (since on
+ dnl cygwin, all socket information should come from sys/socket.h).
+ AC_CHECK_HEADERS([winsock2.h])
+ fi
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ HAVE_WINSOCK2_H=1
+ UNISTD_H_HAVE_WINSOCK2_H=1
+ SYS_IOCTL_H_HAVE_WINSOCK2_H=1
+ else
+ HAVE_WINSOCK2_H=0
+ fi
+ AC_SUBST([HAVE_WINSOCK2_H])
+])
+
+AC_DEFUN([gl_SYS_SOCKET_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_SYS_SOCKET_H_DEFAULTS])
+ GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_SYS_SOCKET_H_DEFAULTS],
+[
+ GNULIB_SOCKET=0; AC_SUBST([GNULIB_SOCKET])
+ GNULIB_CONNECT=0; AC_SUBST([GNULIB_CONNECT])
+ GNULIB_ACCEPT=0; AC_SUBST([GNULIB_ACCEPT])
+ GNULIB_BIND=0; AC_SUBST([GNULIB_BIND])
+ GNULIB_GETPEERNAME=0; AC_SUBST([GNULIB_GETPEERNAME])
+ GNULIB_GETSOCKNAME=0; AC_SUBST([GNULIB_GETSOCKNAME])
+ GNULIB_GETSOCKOPT=0; AC_SUBST([GNULIB_GETSOCKOPT])
+ GNULIB_LISTEN=0; AC_SUBST([GNULIB_LISTEN])
+ GNULIB_RECV=0; AC_SUBST([GNULIB_RECV])
+ GNULIB_SEND=0; AC_SUBST([GNULIB_SEND])
+ GNULIB_RECVFROM=0; AC_SUBST([GNULIB_RECVFROM])
+ GNULIB_SENDTO=0; AC_SUBST([GNULIB_SENDTO])
+ GNULIB_SETSOCKOPT=0; AC_SUBST([GNULIB_SETSOCKOPT])
+ GNULIB_SHUTDOWN=0; AC_SUBST([GNULIB_SHUTDOWN])
+ GNULIB_ACCEPT4=0; AC_SUBST([GNULIB_ACCEPT4])
+ HAVE_STRUCT_SOCKADDR_STORAGE=1; AC_SUBST([HAVE_STRUCT_SOCKADDR_STORAGE])
+ HAVE_SA_FAMILY_T=1; AC_SUBST([HAVE_SA_FAMILY_T])
+ HAVE_ACCEPT4=1; AC_SUBST([HAVE_ACCEPT4])
+])
--- /dev/null
+# sys_stat_h.m4 serial 21 -*- Autoconf -*-
+dnl Copyright (C) 2006-2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Eric Blake.
+dnl Provide a GNU-like <sys/stat.h>.
+
+AC_DEFUN([gl_HEADER_SYS_STAT_H],
+[
+ AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
+
+ dnl For the mkdir substitute.
+ AC_REQUIRE([AC_C_INLINE])
+
+ dnl Check for broken stat macros.
+ AC_REQUIRE([AC_HEADER_STAT])
+
+ gl_CHECK_NEXT_HEADERS([sys/stat.h])
+
+ dnl Define types that are supposed to be defined in <sys/types.h> or
+ dnl <sys/stat.h>.
+ AC_CHECK_TYPE([nlink_t], [],
+ [AC_DEFINE([nlink_t], [int],
+ [Define to the type of st_nlink in struct stat, or a supertype.])],
+ [#include <sys/types.h>
+ #include <sys/stat.h>])
+
+]) # gl_HEADER_SYS_STAT_H
+
+AC_DEFUN([gl_SYS_STAT_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
+ GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_SYS_STAT_H_DEFAULTS],
+[
+ AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) dnl for REPLACE_FCHDIR
+ GNULIB_FCHMODAT=0; AC_SUBST([GNULIB_FCHMODAT])
+ GNULIB_FSTATAT=0; AC_SUBST([GNULIB_FSTATAT])
+ GNULIB_FUTIMENS=0; AC_SUBST([GNULIB_FUTIMENS])
+ GNULIB_LCHMOD=0; AC_SUBST([GNULIB_LCHMOD])
+ GNULIB_LSTAT=0; AC_SUBST([GNULIB_LSTAT])
+ GNULIB_MKDIRAT=0; AC_SUBST([GNULIB_MKDIRAT])
+ GNULIB_MKFIFO=0; AC_SUBST([GNULIB_MKFIFO])
+ GNULIB_MKFIFOAT=0; AC_SUBST([GNULIB_MKFIFOAT])
+ GNULIB_MKNOD=0; AC_SUBST([GNULIB_MKNOD])
+ GNULIB_MKNODAT=0; AC_SUBST([GNULIB_MKNODAT])
+ GNULIB_STAT=0; AC_SUBST([GNULIB_STAT])
+ GNULIB_UTIMENSAT=0; AC_SUBST([GNULIB_UTIMENSAT])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_FCHMODAT=1; AC_SUBST([HAVE_FCHMODAT])
+ HAVE_FSTATAT=1; AC_SUBST([HAVE_FSTATAT])
+ HAVE_FUTIMENS=1; AC_SUBST([HAVE_FUTIMENS])
+ HAVE_LCHMOD=1; AC_SUBST([HAVE_LCHMOD])
+ HAVE_LSTAT=1; AC_SUBST([HAVE_LSTAT])
+ HAVE_MKDIRAT=1; AC_SUBST([HAVE_MKDIRAT])
+ HAVE_MKFIFO=1; AC_SUBST([HAVE_MKFIFO])
+ HAVE_MKFIFOAT=1; AC_SUBST([HAVE_MKFIFOAT])
+ HAVE_MKNOD=1; AC_SUBST([HAVE_MKNOD])
+ HAVE_MKNODAT=1; AC_SUBST([HAVE_MKNODAT])
+ HAVE_UTIMENSAT=1; AC_SUBST([HAVE_UTIMENSAT])
+ REPLACE_FSTAT=0; AC_SUBST([REPLACE_FSTAT])
+ REPLACE_FSTATAT=0; AC_SUBST([REPLACE_FSTATAT])
+ REPLACE_FUTIMENS=0; AC_SUBST([REPLACE_FUTIMENS])
+ REPLACE_LSTAT=0; AC_SUBST([REPLACE_LSTAT])
+ REPLACE_MKDIR=0; AC_SUBST([REPLACE_MKDIR])
+ REPLACE_MKFIFO=0; AC_SUBST([REPLACE_MKFIFO])
+ REPLACE_MKNOD=0; AC_SUBST([REPLACE_MKNOD])
+ REPLACE_STAT=0; AC_SUBST([REPLACE_STAT])
+ REPLACE_UTIMENSAT=0; AC_SUBST([REPLACE_UTIMENSAT])
+])
dnl Reentrant time functions like localtime_r.
-dnl Copyright (C) 2003, 2006, 2007, 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
AC_CACHE_CHECK([whether localtime_r is compatible with its POSIX signature],
[gl_cv_time_r_posix],
- [AC_TRY_COMPILE(
- [#include <time.h>],
- [/* We don't need to append 'restrict's to the argument types,
- even though the POSIX signature has the 'restrict's,
- since C99 says they can't affect type compatibility. */
- struct tm * (*ptr) (time_t const *, struct tm *) = localtime_r;
- if (ptr) return 0;
- /* Check the return type is a pointer. On HP-UX 10 it is 'int'. */
- *localtime_r (0, 0);],
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM(
+ [[#include <time.h>]],
+ [[/* We don't need to append 'restrict's to the argument types,
+ even though the POSIX signature has the 'restrict's,
+ since C99 says they can't affect type compatibility. */
+ struct tm * (*ptr) (time_t const *, struct tm *) = localtime_r;
+ if (ptr) return 0;
+ /* Check the return type is a pointer. On HP-UX 10 it is 'int'. */
+ *localtime_r (0, 0);]])],
[gl_cv_time_r_posix=yes],
[gl_cv_time_r_posix=no])])
if test $gl_cv_time_r_posix = yes; then
-# unistd_h.m4 serial 18
+# unistd_h.m4 serial 36
dnl Copyright (C) 2006-2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
GNULIB_CHOWN=0; AC_SUBST([GNULIB_CHOWN])
GNULIB_CLOSE=0; AC_SUBST([GNULIB_CLOSE])
GNULIB_DUP2=0; AC_SUBST([GNULIB_DUP2])
+ GNULIB_DUP3=0; AC_SUBST([GNULIB_DUP3])
GNULIB_ENVIRON=0; AC_SUBST([GNULIB_ENVIRON])
GNULIB_EUIDACCESS=0; AC_SUBST([GNULIB_EUIDACCESS])
+ GNULIB_FACCESSAT=0; AC_SUBST([GNULIB_FACCESSAT])
GNULIB_FCHDIR=0; AC_SUBST([GNULIB_FCHDIR])
+ GNULIB_FCHOWNAT=0; AC_SUBST([GNULIB_FCHOWNAT])
GNULIB_FSYNC=0; AC_SUBST([GNULIB_FSYNC])
GNULIB_FTRUNCATE=0; AC_SUBST([GNULIB_FTRUNCATE])
GNULIB_GETCWD=0; AC_SUBST([GNULIB_GETCWD])
GNULIB_GETDOMAINNAME=0; AC_SUBST([GNULIB_GETDOMAINNAME])
GNULIB_GETDTABLESIZE=0; AC_SUBST([GNULIB_GETDTABLESIZE])
+ GNULIB_GETGROUPS=0; AC_SUBST([GNULIB_GETGROUPS])
GNULIB_GETHOSTNAME=0; AC_SUBST([GNULIB_GETHOSTNAME])
GNULIB_GETLOGIN_R=0; AC_SUBST([GNULIB_GETLOGIN_R])
GNULIB_GETPAGESIZE=0; AC_SUBST([GNULIB_GETPAGESIZE])
GNULIB_GETUSERSHELL=0; AC_SUBST([GNULIB_GETUSERSHELL])
GNULIB_LCHOWN=0; AC_SUBST([GNULIB_LCHOWN])
GNULIB_LINK=0; AC_SUBST([GNULIB_LINK])
+ GNULIB_LINKAT=0; AC_SUBST([GNULIB_LINKAT])
GNULIB_LSEEK=0; AC_SUBST([GNULIB_LSEEK])
+ GNULIB_PIPE2=0; AC_SUBST([GNULIB_PIPE2])
GNULIB_READLINK=0; AC_SUBST([GNULIB_READLINK])
+ GNULIB_READLINKAT=0; AC_SUBST([GNULIB_READLINKAT])
+ GNULIB_RMDIR=0; AC_SUBST([GNULIB_RMDIR])
GNULIB_SLEEP=0; AC_SUBST([GNULIB_SLEEP])
+ GNULIB_SYMLINK=0; AC_SUBST([GNULIB_SYMLINK])
+ GNULIB_SYMLINKAT=0; AC_SUBST([GNULIB_SYMLINKAT])
+ GNULIB_UNISTD_H_GETOPT=0; AC_SUBST([GNULIB_UNISTD_H_GETOPT])
GNULIB_UNISTD_H_SIGPIPE=0; AC_SUBST([GNULIB_UNISTD_H_SIGPIPE])
+ GNULIB_UNLINK=0; AC_SUBST([GNULIB_UNLINK])
+ GNULIB_UNLINKAT=0; AC_SUBST([GNULIB_UNLINKAT])
+ GNULIB_USLEEP=0; AC_SUBST([GNULIB_USLEEP])
GNULIB_WRITE=0; AC_SUBST([GNULIB_WRITE])
dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_CHOWN=1; AC_SUBST([HAVE_CHOWN])
HAVE_DUP2=1; AC_SUBST([HAVE_DUP2])
+ HAVE_DUP3=1; AC_SUBST([HAVE_DUP3])
HAVE_EUIDACCESS=1; AC_SUBST([HAVE_EUIDACCESS])
+ HAVE_FACCESSAT=1; AC_SUBST([HAVE_FACCESSAT])
+ HAVE_FCHOWNAT=1; AC_SUBST([HAVE_FCHOWNAT])
HAVE_FSYNC=1; AC_SUBST([HAVE_FSYNC])
HAVE_FTRUNCATE=1; AC_SUBST([HAVE_FTRUNCATE])
HAVE_GETDOMAINNAME=1; AC_SUBST([HAVE_GETDOMAINNAME])
HAVE_GETDTABLESIZE=1; AC_SUBST([HAVE_GETDTABLESIZE])
+ HAVE_GETGROUPS=1; AC_SUBST([HAVE_GETGROUPS])
HAVE_GETHOSTNAME=1; AC_SUBST([HAVE_GETHOSTNAME])
HAVE_GETPAGESIZE=1; AC_SUBST([HAVE_GETPAGESIZE])
HAVE_GETUSERSHELL=1; AC_SUBST([HAVE_GETUSERSHELL])
+ HAVE_LCHOWN=1; AC_SUBST([HAVE_LCHOWN])
HAVE_LINK=1; AC_SUBST([HAVE_LINK])
+ HAVE_LINKAT=1; AC_SUBST([HAVE_LINKAT])
+ HAVE_PIPE2=1; AC_SUBST([HAVE_PIPE2])
HAVE_READLINK=1; AC_SUBST([HAVE_READLINK])
+ HAVE_READLINKAT=1; AC_SUBST([HAVE_READLINKAT])
HAVE_SLEEP=1; AC_SUBST([HAVE_SLEEP])
+ HAVE_SYMLINK=1; AC_SUBST([HAVE_SYMLINK])
+ HAVE_SYMLINKAT=1; AC_SUBST([HAVE_SYMLINKAT])
HAVE_DECL_ENVIRON=1; AC_SUBST([HAVE_DECL_ENVIRON])
HAVE_DECL_GETLOGIN_R=1; AC_SUBST([HAVE_DECL_GETLOGIN_R])
HAVE_OS_H=0; AC_SUBST([HAVE_OS_H])
HAVE_SYS_PARAM_H=0; AC_SUBST([HAVE_SYS_PARAM_H])
+ HAVE_UNLINKAT=1; AC_SUBST([HAVE_UNLINKAT])
+ HAVE_USLEEP=1; AC_SUBST([HAVE_USLEEP])
REPLACE_CHOWN=0; AC_SUBST([REPLACE_CHOWN])
REPLACE_CLOSE=0; AC_SUBST([REPLACE_CLOSE])
+ REPLACE_DUP=0; AC_SUBST([REPLACE_DUP])
REPLACE_DUP2=0; AC_SUBST([REPLACE_DUP2])
REPLACE_FCHDIR=0; AC_SUBST([REPLACE_FCHDIR])
+ REPLACE_FCHOWNAT=0; AC_SUBST([REPLACE_FCHOWNAT])
REPLACE_GETCWD=0; AC_SUBST([REPLACE_GETCWD])
+ REPLACE_GETGROUPS=0; AC_SUBST([REPLACE_GETGROUPS])
REPLACE_GETPAGESIZE=0; AC_SUBST([REPLACE_GETPAGESIZE])
REPLACE_LCHOWN=0; AC_SUBST([REPLACE_LCHOWN])
+ REPLACE_LINK=0; AC_SUBST([REPLACE_LINK])
+ REPLACE_LINKAT=0; AC_SUBST([REPLACE_LINKAT])
REPLACE_LSEEK=0; AC_SUBST([REPLACE_LSEEK])
+ REPLACE_READLINK=0; AC_SUBST([REPLACE_READLINK])
+ REPLACE_RMDIR=0; AC_SUBST([REPLACE_RMDIR])
+ REPLACE_SLEEP=0; AC_SUBST([REPLACE_SLEEP])
+ REPLACE_SYMLINK=0; AC_SUBST([REPLACE_SYMLINK])
+ REPLACE_UNLINK=0; AC_SUBST([REPLACE_UNLINK])
+ REPLACE_UNLINKAT=0; AC_SUBST([REPLACE_UNLINKAT])
+ REPLACE_USLEEP=0; AC_SUBST([REPLACE_USLEEP])
REPLACE_WRITE=0; AC_SUBST([REPLACE_WRITE])
UNISTD_H_HAVE_WINSOCK2_H=0; AC_SUBST([UNISTD_H_HAVE_WINSOCK2_H])
+ UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=0;
+ AC_SUBST([UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS])
])
--- /dev/null
+# version-etc.m4 serial 1
+# Copyright (C) 2009 Free Software Foundation, Inc.
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+dnl $1 - configure flag and define name
+dnl $2 - human readable description
+m4_define([gl_VERSION_ETC_FLAG],
+[dnl
+ AC_ARG_WITH([$1], [AS_HELP_STRING([--with-$1], [$2])],
+ [dnl
+ case $withval in
+ yes|no) ;;
+ *) AC_DEFINE_UNQUOTED(AS_TR_CPP([PACKAGE_$1]), ["$withval"], [$2]) ;;
+ esac
+ ])
+])
+
+AC_DEFUN([gl_VERSION_ETC],
+[dnl
+ gl_VERSION_ETC_FLAG([packager],
+ [String identifying the packager of this software])
+ gl_VERSION_ETC_FLAG([packager-version],
+ [Packager-specific version information])
+ gl_VERSION_ETC_FLAG([packager-bug-reports],
+ [Packager info for bug reports (URL/e-mail/...)])
+ if test "X$with_packager" = "X" && \
+ test "X$with_packager_version$with_packager_bug_reports" != "X"
+ then
+ AC_MSG_ERROR([The --with-packager-{bug-reports,version} options require --with-packager])
+ fi
+])
--- /dev/null
+# warnings.m4 serial 2
+dnl Copyright (C) 2008 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Simon Josefsson
+
+# gl_AS_VAR_IF(VAR, VALUE, [IF-MATCH], [IF-NOT-MATCH])
+# ----------------------------------------------------
+# Provide the functionality of AS_VAR_IF if Autoconf does not have it.
+m4_ifdef([AS_VAR_IF],
+[m4_copy([AS_VAR_IF], [gl_AS_VAR_IF])],
+[m4_define([gl_AS_VAR_IF],
+[AS_IF([test x"AS_VAR_GET([$1])" = x""$2], [$3], [$4])])])
+
+# gl_AS_VAR_APPEND(VAR, VALUE)
+# ----------------------------
+# Provide the functionality of AS_VAR_APPEND if Autoconf does not have it.
+m4_ifdef([AS_VAR_APPEND],
+[m4_copy([AS_VAR_APPEND], [gl_AS_VAR_APPEND])],
+[m4_define([gl_AS_VAR_APPEND],
+[AS_VAR_SET([$1], [AS_VAR_GET([$1])$2])])])
+
+# gl_WARN_ADD(PARAMETER, [VARIABLE = WARN_CFLAGS])
+# ------------------------------------------------
+# Adds parameter to WARN_CFLAGS if the compiler supports it. For example,
+# gl_WARN_ADD([-Wparentheses]).
+AC_DEFUN([gl_WARN_ADD],
+[AS_VAR_PUSHDEF([gl_Warn], [gl_cv_warn_$1])dnl
+AC_CACHE_CHECK([whether compiler handles $1], [gl_Warn], [
+ save_CPPFLAGS="$CPPFLAGS"
+ CPPFLAGS="${CPPFLAGS} $1"
+ AC_PREPROC_IFELSE([AC_LANG_PROGRAM([])],
+ [AS_VAR_SET([gl_Warn], [yes])],
+ [AS_VAR_SET([gl_Warn], [no])])
+ CPPFLAGS="$save_CPPFLAGS"
+])
+AS_VAR_PUSHDEF([gl_Flags], m4_if([$2], [], [[WARN_CFLAGS]], [[$2]]))dnl
+gl_AS_VAR_IF([gl_Warn], [yes], [gl_AS_VAR_APPEND([gl_Flags], [" $1"])])
+AS_VAR_POPDEF([gl_Flags])dnl
+AS_VAR_POPDEF([gl_Warn])dnl
+m4_ifval([$2], [AS_LITERAL_IF([$2], [AC_SUBST([$2])], [])])dnl
+])
dnl Written by Eric Blake.
-# wchar.m4 serial 23
+# wchar.m4 serial 26
AC_DEFUN([gl_WCHAR_H],
[
fi
AC_SUBST([HAVE_WINT_T])
- if test $gl_cv_header_wchar_h_standalone != yes || test $gt_cv_c_wint_t != yes; then
+ dnl If <stddef.h> is replaced, then <wchar.h> must also be replaced.
+ AC_REQUIRE([gl_STDDEF_H])
+
+ if test $gl_cv_header_wchar_h_standalone != yes || test $gt_cv_c_wint_t != yes || test -n "$STDDEF_H"; then
WCHAR_H=wchar.h
fi
HAVE_WCHAR_H=0
fi
AC_SUBST([HAVE_WCHAR_H])
+ dnl Execute this unconditionally, because WCHAR_H may be set by other
+ dnl modules, after this code is executed.
gl_CHECK_NEXT_HEADERS([wchar.h])
])
--- /dev/null
+# -*-Makefile-*-
+# This Makefile fragment tries to be general-purpose enough to be
+# used by many projects via the gnulib maintainer-makefile module.
+
+## Copyright (C) 2001-2009 Free Software Foundation, Inc.
+##
+## This program is free software: you can redistribute it and/or modify
+## it under the terms of the GNU General Public License as published by
+## the Free Software Foundation, either version 3 of the License, or
+## (at your option) any later version.
+##
+## This program 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 General Public License for more details.
+##
+## You should have received a copy of the GNU General Public License
+## along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# This is reported not to work with make-3.79.1
+# ME := $(word $(words $(MAKEFILE_LIST)),$(MAKEFILE_LIST))
+ME := maint.mk
+
+# Override this in cfg.mk if you use a non-standard build-aux directory.
+build_aux ?= $(srcdir)/build-aux
+
+# Do not save the original name or timestamp in the .tar.gz file.
+# Use --rsyncable if available.
+gzip_rsyncable := \
+ $(shell gzip --help 2>/dev/null|grep rsyncable >/dev/null && echo --rsyncable)
+GZIP_ENV = '--no-name --best $(gzip_rsyncable)'
+
+# cfg.mk must define the gpg_key_ID used by this package.
+GIT = git
+VC = $(GIT)
+VC-tag = git tag -s -m '$(VERSION)' -u '$(gpg_key_ID)'
+
+VC_LIST = $(build_aux)/vc-list-files -C $(srcdir)
+
+VC_LIST_EXCEPT = \
+ $(VC_LIST) | if test -f $(srcdir)/.x-$@; then grep -vEf $(srcdir)/.x-$@; \
+ else grep -Ev "$${VC_LIST_EXCEPT_DEFAULT-ChangeLog}"; fi
+
+ifeq ($(origin prev_version_file), undefined)
+ prev_version_file = $(srcdir)/.prev-version
+endif
+
+PREV_VERSION := $(shell cat $(prev_version_file) 2>/dev/null)
+VERSION_REGEXP = $(subst .,\.,$(VERSION))
+PREV_VERSION_REGEXP = $(subst .,\.,$(PREV_VERSION))
+
+ifeq ($(VC),$(GIT))
+this-vc-tag = v$(VERSION)
+this-vc-tag-regexp = v$(VERSION_REGEXP)
+else
+tag-package = $(shell echo "$(PACKAGE)" | tr '[:lower:]' '[:upper:]')
+tag-this-version = $(subst .,_,$(VERSION))
+this-vc-tag = $(tag-package)-$(tag-this-version)
+this-vc-tag-regexp = $(this-vc-tag)
+endif
+my_distdir = $(PACKAGE)-$(VERSION)
+
+# Old releases are stored here.
+release_archive_dir ?= ../release
+
+# Override gnu_rel_host and url_dir_list in cfg.mk if these are not right.
+# Use alpha.gnu.org for alpha and beta releases.
+# Use ftp.gnu.org for stable releases.
+gnu_ftp_host-alpha = alpha.gnu.org
+gnu_ftp_host-beta = alpha.gnu.org
+gnu_ftp_host-stable = ftp.gnu.org
+gnu_rel_host ?= $(gnu_ftp_host-$(RELEASE_TYPE))
+
+ifeq ($(gnu_rel_host),ftp.gnu.org)
+url_dir_list ?= http://ftpmirror.gnu.org/$(PACKAGE)
+else
+url_dir_list ?= ftp://$(gnu_rel_host)/gnu/$(PACKAGE)
+endif
+
+# Prevent programs like 'sort' from considering distinct strings to be equal.
+# Doing it here saves us from having to set LC_ALL elsewhere in this file.
+export LC_ALL = C
+
+## --------------- ##
+## Sanity checks. ##
+## --------------- ##
+
+_cfg_mk := $(shell test -f $(srcdir)/cfg.mk && echo '$(srcdir)/cfg.mk')
+
+# Collect the names of rules starting with `sc_'.
+syntax-check-rules := $(sort $(shell sed -n 's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p' \
+ $(srcdir)/$(ME) $(_cfg_mk)))
+.PHONY: $(syntax-check-rules)
+
+local-checks-available = \
+ $(syntax-check-rules)
+.PHONY: $(local-checks-available)
+
+# Arrange to print the name of each syntax-checking rule just before running it.
+$(syntax-check-rules): %: %.m
+$(patsubst %, %.m, $(syntax-check-rules)):
+ @echo $(patsubst sc_%.m, %, $@)
+
+local-check := $(filter-out $(local-checks-to-skip), $(local-checks-available))
+
+syntax-check: $(local-check)
+# @grep -nE '# *include <(limits|std(def|arg|bool))\.h>' \
+# $$(find -type f -name '*.[chly]') && \
+# { echo '$(ME): found conditional include' 1>&2; \
+# exit 1; } || :
+
+# grep -nE '^# *include <(string|stdlib)\.h>' \
+# $(srcdir)/{lib,src}/*.[chy] && \
+# { echo '$(ME): FIXME' 1>&2; \
+# exit 1; } || :
+# FIXME: don't allow `#include .strings\.h' anywhere
+
+# By default, _prohibit_regexp does not ignore case.
+export ignore_case =
+_ignore_case = $$(test -n "$$ignore_case" && echo -i || :)
+
+# There are many rules below that prohibit constructs in this package.
+# If the offending construct can be matched with a grep-E-style regexp,
+# use this macro. The shell variables "re" and "msg" must be defined.
+define _prohibit_regexp
+ dummy=; : so we do not need a semicolon before each use; \
+ test "x$$re" != x || { echo '$(ME): re not defined' 1>&2; exit 1; }; \
+ test "x$$msg" != x || { echo '$(ME): msg not defined' 1>&2; exit 1; };\
+ grep $(_ignore_case) -nE "$$re" $$($(VC_LIST_EXCEPT)) && \
+ { echo '$(ME): '"$$msg" 1>&2; exit 1; } || :
+endef
+
+sc_avoid_if_before_free:
+ @$(build_aux)/useless-if-before-free \
+ $(useless_free_options) \
+ $$($(VC_LIST_EXCEPT) | grep -v useless-if-before-free) && \
+ { echo '$(ME): found useless "if" before "free" above' 1>&2; \
+ exit 1; } || :
+
+sc_cast_of_argument_to_free:
+ @re='\<free *\( *\(' msg='don'\''t cast free argument' \
+ $(_prohibit_regexp)
+
+sc_cast_of_x_alloc_return_value:
+ @re='\*\) *x(m|c|re)alloc\>' \
+ msg='don'\''t cast x*alloc return value' \
+ $(_prohibit_regexp)
+
+sc_cast_of_alloca_return_value:
+ @re='\*\) *alloca\>' msg='don'\''t cast alloca return value' \
+ $(_prohibit_regexp)
+
+sc_space_tab:
+ @re='[ ] ' msg='found SPACE-TAB sequence; remove the SPACE' \
+ $(_prohibit_regexp)
+
+# Don't use *scanf or the old ato* functions in `real' code.
+# They provide no error checking mechanism.
+# Instead, use strto* functions.
+sc_prohibit_atoi_atof:
+ @re='\<([fs]?scanf|ato([filq]|ll)) *\(' \
+ msg='do not use *scan''f, ato''f, ato''i, ato''l, ato''ll or ato''q' \
+ $(_prohibit_regexp)
+
+# Use STREQ rather than comparing strcmp == 0, or != 0.
+sc_prohibit_strcmp:
+ @grep -nE '! *str''cmp *\(|\<str''cmp *\([^)]+\) *==' \
+ $$($(VC_LIST_EXCEPT)) \
+ | grep -vE ':# *define STREQ\(' && \
+ { echo '$(ME): use STREQ in place of the above uses of str''cmp' \
+ 1>&2; exit 1; } || :
+
+# Pass EXIT_*, not number, to usage, exit, and error (when exiting)
+# Convert all uses automatically, via these two commands:
+# git grep -l '\<exit *(1)' \
+# | grep -vEf .x-sc_prohibit_magic_number_exit \
+# | xargs --no-run-if-empty \
+# perl -pi -e 's/(^|[^.])\b(exit ?)\(1\)/$1$2(EXIT_FAILURE)/'
+# git grep -l '\<exit *(0)' \
+# | grep -vEf .x-sc_prohibit_magic_number_exit \
+# | xargs --no-run-if-empty \
+# perl -pi -e 's/(^|[^.])\b(exit ?)\(0\)/$1$2(EXIT_SUCCESS)/'
+sc_prohibit_magic_number_exit:
+ @re='(^|[^.])\<(usage|exit) ?\([0-9]|\<error ?\([1-9][0-9]*,' \
+ msg='use EXIT_* values rather than magic number' \
+ $(_prohibit_regexp)
+
+# Using EXIT_SUCCESS as the first argument to error is misleading,
+# since when that parameter is 0, error does not exit. Use `0' instead.
+sc_error_exit_success:
+ @grep -nE 'error \(EXIT_SUCCESS,' \
+ $$($(VC_LIST_EXCEPT) | grep -E '\.[chly]$$') && \
+ { echo '$(ME): found error (EXIT_SUCCESS' 1>&2; exit 1; } || :
+
+# `FATAL:' should be fully upper-cased in error messages
+# `WARNING:' should be fully upper-cased, or fully lower-cased
+sc_error_message_warn_fatal:
+ @grep -nEA2 '[^rp]error \(' $$($(VC_LIST_EXCEPT)) \
+ | grep -E '"Warning|"Fatal|"fatal' && \
+ { echo '$(ME): use FATAL, WARNING or warning' 1>&2; \
+ exit 1; } || :
+
+# Error messages should not start with a capital letter
+sc_error_message_uppercase:
+ @grep -nEA2 '[^rp]error \(' $$($(VC_LIST_EXCEPT)) \
+ | grep -E '"[A-Z]' \
+ | grep -vE '"FATAL|"WARNING|"Java|"C#|PRIuMAX' && \
+ { echo '$(ME): found capitalized error message' 1>&2; \
+ exit 1; } || :
+
+# Error messages should not end with a period
+sc_error_message_period:
+ @grep -nEA2 '[^rp]error \(' $$($(VC_LIST_EXCEPT)) \
+ | grep -E '[^."]\."' && \
+ { echo '$(ME): found error message ending in period' 1>&2; \
+ exit 1; } || :
+
+sc_file_system:
+ @re=file''system ignore_case=1 \
+ msg='found use of "file''system"; spell it "file system"' \
+ $(_prohibit_regexp)
+
+# Don't use cpp tests of this symbol. All code assumes config.h is included.
+sc_prohibit_have_config_h:
+ @grep -n '^# *if.*HAVE''_CONFIG_H' $$($(VC_LIST_EXCEPT)) && \
+ { echo '$(ME): found use of HAVE''_CONFIG_H; remove' \
+ 1>&2; exit 1; } || :
+
+# Nearly all .c files must include <config.h>. However, we also permit this
+# via inclusion of a package-specific header, if cfg.mk specified one.
+# config_h_header must be suitable for grep -E.
+config_h_header ?= <config\.h>
+sc_require_config_h:
+ @if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \
+ grep -EL '^# *include $(config_h_header)' \
+ $$($(VC_LIST_EXCEPT) | grep '\.c$$') \
+ | grep . && \
+ { echo '$(ME): the above files do not include <config.h>' \
+ 1>&2; exit 1; } || :; \
+ else :; \
+ fi
+
+# You must include <config.h> before including any other header file.
+# This can possibly be via a package-specific header, if given by cfg.mk.
+sc_require_config_h_first:
+ @if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \
+ fail=0; \
+ for i in $$($(VC_LIST_EXCEPT) | grep '\.c$$'); do \
+ grep '^# *include\>' $$i | sed 1q \
+ | grep -E '^# *include $(config_h_header)' > /dev/null \
+ || { echo $$i; fail=1; }; \
+ done; \
+ test $$fail = 1 && \
+ { echo '$(ME): the above files include some other header' \
+ 'before <config.h>' 1>&2; exit 1; } || :; \
+ else :; \
+ fi
+
+sc_prohibit_HAVE_MBRTOWC:
+ @re='\bHAVE_MBRTOWC\b' msg="do not use $$re; it is always defined" \
+ $(_prohibit_regexp)
+
+# To use this "command" macro, you must first define two shell variables:
+# h: the header, enclosed in <> or ""
+# re: a regular expression that matches IFF something provided by $h is used.
+define _header_without_use
+ dummy=; : so we do not need a semicolon before each use; \
+ h_esc=`echo "$$h"|sed 's/\./\\\\./g'`; \
+ if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \
+ files=$$(grep -l '^# *include '"$$h_esc" \
+ $$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \
+ grep -LE "$$re" $$files | grep . && \
+ { echo "$(ME): the above files include $$h but don't use it" \
+ 1>&2; exit 1; } || :; \
+ else :; \
+ fi
+endef
+
+# Prohibit the inclusion of assert.h without an actual use of assert.
+sc_prohibit_assert_without_use:
+ @h='<assert.h>' re='\<assert *\(' $(_header_without_use)
+
+# Prohibit the inclusion of close-stream.h without an actual use.
+sc_prohibit_close_stream_without_use:
+ @h='"close-stream.h"' re='\<close_stream *\(' $(_header_without_use)
+
+# Prohibit the inclusion of getopt.h without an actual use.
+sc_prohibit_getopt_without_use:
+ @h='<getopt.h>' re='\<getopt(_long)? *\(' $(_header_without_use)
+
+# Don't include quotearg.h unless you use one of its functions.
+sc_prohibit_quotearg_without_use:
+ @h='"quotearg.h"' re='\<quotearg(_[^ ]+)? *\(' $(_header_without_use)
+
+# Don't include quote.h unless you use one of its functions.
+sc_prohibit_quote_without_use:
+ @h='"quote.h"' re='\<quote(_n)? *\(' $(_header_without_use)
+
+# Don't include this header unless you use one of its functions.
+sc_prohibit_long_options_without_use:
+ @h='"long-options.h"' re='\<parse_long_options *\(' \
+ $(_header_without_use)
+
+# Don't include this header unless you use one of its functions.
+sc_prohibit_inttostr_without_use:
+ @h='"inttostr.h"' re='\<(off|[iu]max|uint)tostr *\(' \
+ $(_header_without_use)
+
+# Don't include this header unless you use one of its functions.
+sc_prohibit_error_without_use:
+ @h='"error.h"' \
+ re='\<error(_at_line|_print_progname|_one_per_line|_message_count)? *\('\
+ $(_header_without_use)
+
+# Don't include xalloc.h unless you use one of its functions.
+# Consider these symbols:
+# perl -lne '/^# *define (\w+)\(/ and print $1' lib/xalloc.h|grep -v '^__';
+# perl -lne '/^(?:extern )?(?:void|char) \*?(\w+) \(/ and print $1' lib/xalloc.h
+# Divide into two sets on case, and filter each through this:
+# | sort | perl -MRegexp::Assemble -le \
+# 'print Regexp::Assemble->new(file => "/dev/stdin")->as_string'|sed 's/\?://g'
+# Note this was produced by the above:
+# _xa1 = x(alloc_(oversized|die)|([cz]|2?re)alloc|m(alloc|emdup)|strdup)
+# But we can do better:
+_xa1 = x(alloc_(oversized|die)|([cmz]|2?re)alloc|(mem|str)dup)
+_xa2 = X([CZ]|N?M)ALLOC
+sc_prohibit_xalloc_without_use:
+ @h='"xalloc.h"' \
+ re='\<($(_xa1)|$(_xa2)) *\('\
+ $(_header_without_use)
+
+sc_prohibit_safe_read_without_use:
+ @h='"safe-read.h"' re='(\<SAFE_READ_ERROR\>|\<safe_read *\()' \
+ $(_header_without_use)
+
+sc_prohibit_argmatch_without_use:
+ @h='"argmatch.h"' \
+ re='(\<(ARRAY_CARDINALITY|X?ARGMATCH(|_TO_ARGUMENT|_VERIFY))\>|\<argmatch(_exit_fn|_(in)?valid) *\()' \
+ $(_header_without_use)
+
+sc_prohibit_canonicalize_without_use:
+ @h='"canonicalize.h"' \
+ re='CAN_(EXISTING|ALL_BUT_LAST|MISSING)|canonicalize_(mode_t|filename_mode)' \
+ $(_header_without_use)
+
+sc_prohibit_root_dev_ino_without_use:
+ @h='"root-dev-ino.h"' \
+ re='(\<ROOT_DEV_INO_(CHECK|WARN)\>|\<get_root_dev_ino *\()' \
+ $(_header_without_use)
+
+sc_prohibit_openat_without_use:
+ @h='"openat.h"' \
+ re='\<(openat_(permissive|needs_fchdir|(save|restore)_fail)|l?(stat|ch(own|mod))at|(euid)?accessat)\>' \
+ $(_header_without_use)
+
+# Prohibit the inclusion of c-ctype.h without an actual use.
+ctype_re = isalnum|isalpha|isascii|isblank|iscntrl|isdigit|isgraph|islower\
+|isprint|ispunct|isspace|isupper|isxdigit|tolower|toupper
+sc_prohibit_c_ctype_without_use:
+ @h='[<"]c-ctype.h[">]' re='\<c_($(ctype_re)) *\(' $(_header_without_use)
+
+_empty =
+_sp = $(_empty) $(_empty)
+# The following list was generated by running:
+# man signal.h|col -b|perl -ne '/bsd_signal.*;/.../sigwaitinfo.*;/ and print' \
+# | perl -lne '/^\s+(?:int|void).*?(\w+).*/ and print $1' | fmt
+_sig_functions = \
+ bsd_signal kill killpg pthread_kill pthread_sigmask raise sigaction \
+ sigaddset sigaltstack sigdelset sigemptyset sigfillset sighold sigignore \
+ siginterrupt sigismember signal sigpause sigpending sigprocmask sigqueue \
+ sigrelse sigset sigsuspend sigtimedwait sigwait sigwaitinfo
+_sig_function_re = $(subst $(_sp),|,$(strip $(_sig_functions)))
+# The following were extracted from "man signal.h" manually.
+_sig_types_and_consts = \
+ MINSIGSTKSZ SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK \
+ SA_RESETHAND SA_RESTART SA_SIGINFO SIGEV_NONE SIGEV_SIGNAL \
+ SIGEV_THREAD SIGSTKSZ SIG_BLOCK SIG_SETMASK SIG_UNBLOCK SS_DISABLE \
+ SS_ONSTACK mcontext_t pid_t sig_atomic_t sigevent siginfo_t sigset_t \
+ sigstack sigval stack_t ucontext_t
+# generated via this:
+# perl -lne '/^#ifdef (SIG\w+)/ and print $1' lib/sig2str.c|sort -u|fmt -70
+_sig_names = \
+ SIGABRT SIGALRM SIGALRM1 SIGBUS SIGCANCEL SIGCHLD SIGCLD SIGCONT \
+ SIGDANGER SIGDIL SIGEMT SIGFPE SIGFREEZE SIGGRANT SIGHUP SIGILL \
+ SIGINFO SIGINT SIGIO SIGIOT SIGKAP SIGKILL SIGKILLTHR SIGLOST SIGLWP \
+ SIGMIGRATE SIGMSG SIGPHONE SIGPIPE SIGPOLL SIGPRE SIGPROF SIGPWR \
+ SIGQUIT SIGRETRACT SIGSAK SIGSEGV SIGSOUND SIGSTKFLT SIGSTOP SIGSYS \
+ SIGTERM SIGTHAW SIGTRAP SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1 \
+ SIGUSR2 SIGVIRT SIGVTALRM SIGWAITING SIGWINCH SIGWIND SIGWINDOW \
+ SIGXCPU SIGXFSZ
+_sig_syms_re = $(subst $(_sp),|,$(strip $(_sig_names) $(_sig_types_and_consts)))
+
+# Prohibit the inclusion of signal.h without an actual use.
+sc_prohibit_signal_without_use:
+ @h='<signal.h>' \
+ re='\<($(_sig_function_re)) *\(|\<($(_sig_syms_re))\>' \
+ $(_header_without_use)
+
+sc_obsolete_symbols:
+ @re='\<(HAVE''_FCNTL_H|O''_NDELAY)\>' \
+ msg='do not use HAVE''_FCNTL_H or O'_NDELAY \
+ $(_prohibit_regexp)
+
+# FIXME: warn about definitions of EXIT_FAILURE, EXIT_SUCCESS, STREQ
+
+# Each nonempty ChangeLog line must start with a year number, or a TAB.
+sc_changelog:
+ @if $(VC_LIST_EXCEPT) | grep -l '^ChangeLog$$' >/dev/null; then \
+ grep -n '^[^12 ]' \
+ $$($(VC_LIST_EXCEPT) | grep '^ChangeLog$$') && \
+ { echo '$(ME): found unexpected prefix in a ChangeLog' 1>&2; \
+ exit 1; } || :; \
+ fi
+
+# Ensure that each .c file containing a "main" function also
+# calls set_program_name.
+sc_program_name:
+ @if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \
+ files=$$(grep -l '^main *(' $$($(VC_LIST_EXCEPT) | grep '\.c$$')); \
+ grep -LE 'set_program_name *\(m?argv\[0\]\);' $$files \
+ | grep . && \
+ { echo '$(ME): the above files do not call set_program_name' \
+ 1>&2; exit 1; } || :; \
+ else :; \
+ fi
+
+# Require that the final line of each test-lib.sh-using test be this one:
+# Exit $fail
+# Note: this test requires GNU grep's --label= option.
+Exit_witness_file ?= tests/test-lib.sh
+Exit_base := $(notdir $(Exit_witness_file))
+sc_require_test_exit_idiom:
+ @if test -f $(srcdir)/$(Exit_witness_file); then \
+ die=0; \
+ for i in $$(grep -l -F 'srcdir/$(Exit_base)' \
+ $$($(VC_LIST) tests)); do \
+ tail -n1 $$i | grep '^Exit .' > /dev/null \
+ && : || { die=1; echo $$i; } \
+ done; \
+ test $$die = 1 && \
+ { echo 1>&2 '$(ME): the final line in each of the above is not:'; \
+ echo 1>&2 'Exit something'; \
+ exit 1; } || :; \
+ fi
+
+sc_the_the:
+ @re='\<the ''the\>' \
+ ignore_case=1 msg='found use of "the ''the";' \
+ $(_prohibit_regexp)
+
+sc_trailing_blank:
+ @re='[ ]$$' \
+ msg='found trailing blank(s)' \
+ $(_prohibit_regexp)
+
+# Match lines like the following, but where there is only one space
+# between the options and the description:
+# -D, --all-repeated[=delimit-method] print all duplicate lines\n
+longopt_re = --[a-z][0-9A-Za-z-]*(\[?=[0-9A-Za-z-]*\]?)?
+sc_two_space_separator_in_usage:
+ @grep -nE '^ *(-[A-Za-z],)? $(longopt_re) [^ ].*\\$$' \
+ $$($(VC_LIST_EXCEPT)) && \
+ { echo "$(ME): help2man requires at least two spaces between"; \
+ echo "$(ME): an option and its description"; \
+ 1>&2; exit 1; } || :
+
+# Look for diagnostics that aren't marked for translation.
+# This won't find any for which error's format string is on a separate line.
+sc_unmarked_diagnostics:
+ @grep -nE \
+ '\<error \([^"]*"[^"]*[a-z]{3}' $$($(VC_LIST_EXCEPT)) \
+ | grep -v '_''(' && \
+ { echo '$(ME): found unmarked diagnostic(s)' 1>&2; \
+ exit 1; } || :
+
+# Avoid useless parentheses like those in this example:
+# #if defined (SYMBOL) || defined (SYM2)
+sc_useless_cpp_parens:
+ @grep -n '^# *if .*defined *(' $$($(VC_LIST_EXCEPT)) && \
+ { echo '$(ME): found useless parentheses in cpp directive' \
+ 1>&2; exit 1; } || :
+
+# Require the latest GPL.
+sc_GPL_version:
+ @re='either ''version [^3]' msg='GPL vN, N!=3' \
+ $(_prohibit_regexp)
+
+cvs_keywords = \
+ Author|Date|Header|Id|Name|Locker|Log|RCSfile|Revision|Source|State
+
+sc_prohibit_cvs_keyword:
+ @re='\$$($(cvs_keywords))\$$' \
+ msg='do not use CVS keyword expansion' \
+ $(_prohibit_regexp)
+
+# Make sure we don't use st_blocks. Use ST_NBLOCKS instead.
+# This is a bit of a kludge, since it prevents use of the string
+# even in comments, but for now it does the job with no false positives.
+sc_prohibit_stat_st_blocks:
+ @re='[.>]st_blocks' msg='do not use st_blocks; use ST_NBLOCKS' \
+ $(_prohibit_regexp)
+
+# Make sure we don't define any S_IS* macros in src/*.c files.
+# They're already defined via gnulib's sys/stat.h replacement.
+sc_prohibit_S_IS_definition:
+ @re='^ *# *define *S_IS' \
+ msg='do not define S_IS* macros; include <sys/stat.h>' \
+ $(_prohibit_regexp)
+
+# Each program that uses proper_name_utf8 must link with
+# one of the ICONV libraries.
+sc_proper_name_utf8_requires_ICONV:
+ @progs=$$(grep -l 'proper_name_utf8 ''("' $$($(VC_LIST_EXCEPT)));\
+ if test "x$$progs" != x; then \
+ fail=0; \
+ for p in $$progs; do \
+ dir=$$(dirname "$$p"); \
+ base=$$(basename "$$p" .c); \
+ grep "$${base}_LDADD.*ICONV)" $$dir/Makefile.am > /dev/null \
+ || { fail=1; echo 1>&2 "$(ME): $$p uses proper_name_utf8"; }; \
+ done; \
+ test $$fail = 1 && \
+ { echo 1>&2 '$(ME): the above do not link with any ICONV library'; \
+ exit 1; } || :; \
+ fi
+
+# Warn about "c0nst struct Foo const foo[]",
+# but not about "char const *const foo" or "#define const const".
+sc_redundant_const:
+ @re='\bconst\b[[:space:][:alnum:]]{2,}\bconst\b' \
+ msg='redundant "const" in declarations' \
+ $(_prohibit_regexp)
+
+sc_const_long_option:
+ @grep '^ *static.*struct option ' $$($(VC_LIST_EXCEPT)) \
+ | grep -Ev 'const struct option|struct option const' && { \
+ echo 1>&2 '$(ME): add "const" to the above declarations'; \
+ exit 1; } || :
+
+NEWS_hash = \
+ $$(sed -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \
+ $(srcdir)/NEWS \
+ | grep -v '^Copyright .*Free Software' \
+ | md5sum - \
+ | sed 's/ .*//')
+
+# Ensure that we don't accidentally insert an entry into an old NEWS block.
+sc_immutable_NEWS:
+ @if test -f $(srcdir)/NEWS; then \
+ test "$(NEWS_hash)" = '$(old_NEWS_hash)' && : || \
+ { echo '$(ME): you have modified old NEWS' 1>&2; exit 1; }; \
+ fi
+
+# Update the hash stored above. Do this after each release and
+# for any corrections to old entries.
+update-NEWS-hash: NEWS
+ perl -pi -e 's/^(old_NEWS_hash[ \t]+:?=[ \t]+).*/$${1}'"$(NEWS_hash)/" \
+ $(srcdir)/cfg.mk
+
+# Ensure that we use only the standard $(VAR) notation,
+# not @...@ in Makefile.am, now that we can rely on automake
+# to emit a definition for each substituted variable.
+# We use perl rather than "grep -nE ..." to exempt a single
+# use of an @...@-delimited variable name in src/Makefile.am.
+sc_makefile_check:
+ @perl -ne '/\@[A-Z_0-9]+\@/ && !/^cu_install_program =/' \
+ -e 'and (print "$$ARGV:$$.: $$_"), $$m=1; END {exit !$$m}' \
+ $$($(VC_LIST_EXCEPT) | grep -E '(^|/)Makefile\.am$$') \
+ && { echo '$(ME): use $$(...), not @...@' 1>&2; exit 1; } || :
+
+news-date-check: NEWS
+ today=`date +%Y-%m-%d`; \
+ if head $(srcdir)/NEWS | grep '^\*.* $(VERSION_REGEXP) ('$$today')' \
+ >/dev/null; then \
+ :; \
+ else \
+ echo "version or today's date is not in NEWS" 1>&2; \
+ exit 1; \
+ fi
+
+sc_makefile_TAB_only_indentation:
+ @grep -nE '^ [ ]{8}' \
+ $$($(VC_LIST_EXCEPT) | grep -E 'akefile|\.mk$$') \
+ && { echo '$(ME): found TAB-8-space indentation' 1>&2; \
+ exit 1; } || :
+
+sc_m4_quote_check:
+ @grep -nE '(AC_DEFINE(_UNQUOTED)?|AC_DEFUN)\([^[]' \
+ $$($(VC_LIST_EXCEPT) | grep -E '(^configure\.ac|\.m4)$$') \
+ && { echo '$(ME): quote the first arg to AC_DEF*' 1>&2; \
+ exit 1; } || :
+
+fix_po_file_diag = \
+'you have changed the set of files with translatable diagnostics;\n\
+apply the above patch\n'
+
+# Verify that all source files using _() are listed in po/POTFILES.in.
+po_file = po/POTFILES.in
+sc_po_check:
+ @if test -f $(po_file); then \
+ grep -E -v '^(#|$$)' $(po_file) \
+ | grep -v '^src/false\.c$$' | sort > $@-1; \
+ files=; \
+ for file in $$($(VC_LIST_EXCEPT)) lib/*.[ch]; do \
+ test -r $$file || continue; \
+ case $$file in \
+ *.m4|*.mk) continue ;; \
+ *.?|*.??) ;; \
+ *) continue;; \
+ esac; \
+ case $$file in \
+ *.[ch]) \
+ base=`expr " $$file" : ' \(.*\)\..'`; \
+ { test -f $$base.l || test -f $$base.y; } && continue;; \
+ esac; \
+ files="$$files $$file"; \
+ done; \
+ grep -E -l '\b(N?_|gettext *)\([^)"]*("|$$)' $$files \
+ | sort -u > $@-2; \
+ diff -u -L $(po_file) -L $(po_file) $@-1 $@-2 \
+ || { printf '$(ME): '$(fix_po_file_diag) 1>&2; exit 1; }; \
+ rm -f $@-1 $@-2; \
+ fi
+
+# Sometimes it is useful to change the PATH environment variable
+# in Makefiles. When doing so, it's better not to use the Unix-centric
+# path separator of `:', but rather the automake-provided `$(PATH_SEPARATOR)'.
+msg = '$(ME): Do not use `:'\'' above; use $$(PATH_SEPARATOR) instead'
+sc_makefile_path_separator_check:
+ @grep -nE 'PATH[=].*:' \
+ $$($(VC_LIST_EXCEPT) | grep -E 'akefile|\.mk$$') \
+ && { echo $(msg) 1>&2; exit 1; } || :
+
+# Check that `make alpha' will not fail at the end of the process.
+writable-files:
+ if test -d $(release_archive_dir); then :; else \
+ for file in $(distdir).tar.gz \
+ $(release_archive_dir)/$(distdir).tar.gz; do \
+ test -e $$file || continue; \
+ test -w $$file \
+ || { echo ERROR: $$file is not writable; fail=1; }; \
+ done; \
+ test "$$fail" && exit 1 || : ; \
+ fi
+
+v_etc_file = lib/version-etc.c
+sample-test = tests/sample-test
+texi = doc/$(PACKAGE).texi
+# Make sure that the copyright date in $(v_etc_file) is up to date.
+# Do the same for the $(sample-test) and the main doc/.texi file.
+sc_copyright_check:
+ @if test -f $(v_etc_file); then \
+ grep 'enum { COPYRIGHT_YEAR = '$$(date +%Y)' };' $(v_etc_file) \
+ >/dev/null \
+ || { echo 'out of date copyright in $(v_etc_file); update it' 1>&2; \
+ exit 1; }; \
+ fi
+ @if test -f $(sample-test); then \
+ grep '# Copyright (C) '$$(date +%Y)' Free' $(sample-test) \
+ >/dev/null \
+ || { echo 'out of date copyright in $(sample-test); update it' 1>&2; \
+ exit 1; }; \
+ fi
+ @if test -f $(texi); then \
+ grep 'Copyright @copyright{} .*'$$(date +%Y)' Free' $(texi) \
+ >/dev/null \
+ || { echo 'out of date copyright in $(texi); update it' 1>&2; \
+ exit 1; }; \
+ fi
+
+vc-diff-check:
+ (unset CDPATH; cd $(srcdir) && $(VC) diff) > vc-diffs || :
+ if test -s vc-diffs; then \
+ cat vc-diffs; \
+ echo "Some files are locally modified:" 1>&2; \
+ exit 1; \
+ else \
+ rm vc-diffs; \
+ fi
+
+# Use this to make sure we don't run these programs when building
+# from a virgin tgz file, below.
+null_AM_MAKEFLAGS = \
+ ACLOCAL=false \
+ AUTOCONF=false \
+ AUTOMAKE=false \
+ AUTOHEADER=false \
+ MAKEINFO=false
+
+built_programs = $$(cd src && MAKEFLAGS= $(MAKE) -s built_programs.list)
+
+rel-files = $(DIST_ARCHIVES)
+
+gnulib_dir ?= $(srcdir)/gnulib
+gnulib-version = $$(cd $(gnulib_dir) && git describe)
+bootstrap-tools ?= autoconf,automake,gnulib
+
+announcement: NEWS ChangeLog $(rel-files)
+ @$(build_aux)/announce-gen \
+ --release-type=$(RELEASE_TYPE) \
+ --package=$(PACKAGE) \
+ --prev=$(PREV_VERSION) \
+ --curr=$(VERSION) \
+ --gpg-key-id=$(gpg_key_ID) \
+ --news=NEWS \
+ --bootstrap-tools=$(bootstrap-tools) \
+ --gnulib-version=$(gnulib-version) \
+ --no-print-checksums \
+ $(addprefix --url-dir=, $(url_dir_list))
+
+## ---------------- ##
+## Updating files. ##
+## ---------------- ##
+
+ftp-gnu = ftp://ftp.gnu.org/gnu
+www-gnu = http://www.gnu.org
+
+emit_upload_commands:
+ @echo =====================================
+ @echo =====================================
+ @echo "$(build_aux)/gnupload $(GNUPLOADFLAGS) \\"
+ @echo " --to $(gnu_rel_host):$(PACKAGE) \\"
+ @echo " $(rel-files)"
+ @echo '# send the /tmp/announcement e-mail'
+ @echo =====================================
+ @echo =====================================
+
+noteworthy = * Noteworthy changes in release ?.? (????-??-??) [?]
+define emit-commit-log
+ printf '%s\n' 'post-release administrivia' '' \
+ '* NEWS: Add header line for next release.' \
+ '* .prev-version: Record previous version.' \
+ '* cfg.mk (old_NEWS_hash): Auto-update.'
+endef
+
+.PHONY: no-submodule-changes
+no-submodule-changes:
+ if test -d $(srcdir)/.git; then \
+ diff=$$(cd $(srcdir) && git submodule -q foreach \
+ git diff-index --name-only HEAD) \
+ || exit 1; \
+ case $$diff in '') ;; \
+ *) echo '$(ME): submodule files are locally modified:'; \
+ echo "$$diff"; exit 1;; esac; \
+ else \
+ : ; \
+ fi
+
+.PHONY: alpha beta stable
+ALL_RECURSIVE_TARGETS += alpha beta stable
+alpha beta stable: $(local-check) writable-files no-submodule-changes
+ test $@ = stable \
+ && { echo $(VERSION) | grep -E '^[0-9]+(\.[0-9]+)+$$' \
+ || { echo "invalid version string: $(VERSION)" 1>&2; exit 1;};}\
+ || :
+ $(MAKE) vc-diff-check
+ $(MAKE) news-date-check
+ $(MAKE) distcheck
+ $(MAKE) dist XZ_OPT=-9ev
+ $(MAKE) -s announcement RELEASE_TYPE=$@ > /tmp/announce-$(my_distdir)
+ if test -d $(release_archive_dir); then \
+ ln $(rel-files) $(release_archive_dir); \
+ chmod a-w $(rel-files); \
+ fi
+ $(MAKE) -s emit_upload_commands RELEASE_TYPE=$@
+ echo $(VERSION) > $(prev_version_file)
+ $(MAKE) update-NEWS-hash
+ perl -pi -e '$$. == 3 and print "$(noteworthy)\n\n\n"' NEWS
+ $(emit-commit-log) > .ci-msg
+ $(VC) commit -F .ci-msg -a
+
+.PHONY: web-manual
+web-manual:
+ @test -z "$(manual_title)" \
+ && { echo define manual_title in cfg.mk 1>&2; exit 1; } || :
+ @cd '$(srcdir)/doc'; \
+ $(SHELL) ../build-aux/gendocs.sh -o '$(abs_builddir)/doc/manual' \
+ --email $(PACKAGE_BUGREPORT) $(PACKAGE) \
+ "$(PACKAGE_NAME) - $(manual_title)"
+ @echo " *** Upload the doc/manual directory to web-cvs."
+
+# Code Coverage
+
+init-coverage:
+ $(MAKE) $(AM_MAKEFLAGS) clean
+ lcov --directory . --zerocounters
+
+COVERAGE_CCOPTS ?= "-g --coverage"
+COVERAGE_OUT ?= doc/coverage
+
+build-coverage:
+ $(MAKE) $(AM_MAKEFLAGS) CFLAGS=$(COVERAGE_CCOPTS) CXXFLAGS=$(COVERAGE_CCOPTS)
+ $(MAKE) $(AM_MAKEFLAGS) CFLAGS=$(COVERAGE_CCOPTS) CXXFLAGS=$(COVERAGE_CCOPTS) check
+ mkdir -p $(COVERAGE_OUT)
+ lcov --directory . --output-file $(COVERAGE_OUT)/$(PACKAGE).info \
+ --capture
+
+gen-coverage:
+ genhtml --output-directory $(COVERAGE_OUT) \
+ $(COVERAGE_OUT)/$(PACKAGE).info \
+ --highlight --frames --legend \
+ --title "$(PACKAGE_NAME)"
+
+coverage: init-coverage build-coverage gen-coverage
+
+# Update gettext files.
+PACKAGE ?= $(shell basename $(PWD))
+PO_DOMAIN ?= $(PACKAGE)
+POURL = http://translationproject.org/latest/$(PO_DOMAIN)/
+PODIR ?= po
+refresh-po:
+ rm -f $(PODIR)/*.po && \
+ echo "$(ME): getting translations into po (please ignore the robots.txt ERROR 404)..." && \
+ wget --no-verbose --directory-prefix $(PODIR) --no-directories --recursive --level 1 --accept .po --accept .po.1 $(POURL) && \
+ echo 'en@boldquot' > $(PODIR)/LINGUAS && \
+ echo 'en@quot' >> $(PODIR)/LINGUAS && \
+ ls $(PODIR)/*.po | sed 's/\.po//' | sed 's,$(PODIR)/,,' | sort >> $(PODIR)/LINGUAS
+
+INDENT_SOURCES ?= $(C_SOURCES)
+.PHONY: indent
+indent:
+ indent $(INDENT_SOURCES)
+
+# If you want to set UPDATE_COPYRIGHT_* environment variables,
+# put the assignments in this variable.
+update-copyright-env ?=
+
+# Run this rule once per year (usually early in January)
+# to update all FSF copyright year lists in your project.
+# If you have an additional project-specific rule,
+# add it in cfg.mk along with a line 'update-copyright: prereq'.
+# By default, exclude all variants of COPYING; you can also
+# add exemptions (such as ChangeLog..* for rotated change logs)
+# in the file .x-update-copyright.
+.PHONY: update-copyright
+update-copyright:
+ grep -l -w Copyright \
+ $$(export VC_LIST_EXCEPT_DEFAULT=COPYING && $(VC_LIST_EXCEPT)) \
+ | $(update-copyright-env) xargs $(build_aux)/$@
## Fifth Floor, Boston, MA 02110-1301 USA
bin_SCRIPTS = guile-config guile-tools
-EXTRA_DIST= $(bin_SCRIPTS) \
+EXTRA_DIST= \
guile.m4 ChangeLog-2008 \
guile-2.0.pc.in guile-2.0-uninstalled.pc.in \
- guile-tools.in
+ guile-tools.in guile-config.in
pkgconfigdir = $(libdir)/pkgconfig
pkgconfig_DATA = guile-2.0.pc
## doing this. When that happens, switch over.
aclocaldir = $(datadir)/aclocal
aclocal_DATA = guile.m4
+
+guile-config: $(srcdir)/guile-config.in
+ guile="@bindir@/`echo guile | $(SED) -e '$(program_transform_name)'`" ; \
+ cat $(srcdir)/guile-config.in \
+ | $(SED) -e "s,@pkgconfigdir@,$(pkgconfigdir),g ; \
+ s,@""PKG_CONFIG@,$(PKG_CONFIG),g ; \
+ s,@installed_guile@,$$guile,g" \
+ > guile-config.out
+ mv guile-config.out guile-config
+ chmod +x guile-config
+
+CLEANFILES = guile-config
top_builddir="@top_builddir_absolute@"
XDG_CACHE_HOME=${top_builddir}/cache
export XDG_CACHE_HOME
-exec ${top_builddir}/meta/uninstalled-env libtool --mode=execute \
+exec ${top_builddir}/meta/uninstalled-env ${top_builddir}/libtool --mode=execute \
gdb --args ${top_builddir}/libguile/guile "$@"
+
+# And for GDB in Emacs, evaluate this form:
+# (gdb "@top_builddir_absolute@/meta/uninstalled-env ../libtool --mode=execute gdb --annotate=3 --args @top_builddir_absolute@/libguile/guile")
Description: GNU's Ubiquitous Intelligent Language for Extension (uninstalled)
Version: @GUILE_VERSION@
Libs: -L${builddir}/libguile -lguile @GUILE_LIBS@
-Cflags: -I${srcdir} -I${builddir} @GUILE_CFLAGS@
+Cflags: -I${srcdir} -I${builddir} @GUILE_CFLAGS@ @BDW_GC_CFLAGS@
pkgdatadir=@datadir@/guile
sitedir=@sitedir@
+extensionsdir=@libdir@/guile/@GUILE_EFFECTIVE_VERSION@/extensions
libguileinterface=@LIBGUILE_INTERFACE@
Name: GNU Guile
Description: GNU's Ubiquitous Intelligent Language for Extension
Version: @GUILE_VERSION@
Libs: -L${libdir} -lguile @GUILE_LIBS@
-Cflags: -I${includedir} @GUILE_CFLAGS@
+Cflags: -I${includedir} @GUILE_CFLAGS@ @BDW_GC_CFLAGS@
#!/bin/sh
-exec guile -e main -s $0 "$@"
+PKG_CONFIG_PATH="@pkgconfigdir@:$PKG_CONFIG_PATH"
+GUILE_AUTO_COMPILE=0
+export PKG_CONFIG_PATH GUILE_AUTO_COMPILE
+
+exec "@installed_guile@" -e main -s $0 "$@"
!#
;;;; guile-config --- utility for linking programs with Guile
;;;; Jim Blandy <jim@red-bean.com> --- September 1997
(ice-9 rdelim))
\f
+(define %pkg-config-program "@PKG_CONFIG@")
+
;;;; main function, command-line processing
;;; The script's entry point.
(define guile-module "guile-2.0")
(define (pkg-config . args)
- (let* ((real-args (cons "pkg-config" args))
+ (let* ((real-args (cons %pkg-config-program args))
(pipe (apply open-pipe* OPEN_READ real-args))
(output (read-delimited "" pipe))
(ret (close-pipe pipe)))
((0) (if (eof-object? output) "" output))
(else (display-line-error
(format #f "error: ~s exited with non-zero error code ~A"
- (cons "pkg-config" args) (status:exit-val ret)))
+ (cons %pkg-config-program args) (status:exit-val ret)))
;; assume pkg-config sent diagnostics to stdout
(exit (status:exit-val ret))))))
if ( env | grep -v -q -E '^GUILE_SYSTEM_COMPILED_PATH=' ); then
export GUILE_SYSTEM_COMPILED_PATH=
fi
+# Don't look in installed dirs for dlopen-able modules
+if ( env | grep -v -q -E '^GUILE_SYSTEM_EXTENSIONS_PATH=' ); then
+ export GUILE_SYSTEM_EXTENSIONS_PATH=
+fi
# handle LTDL_LIBRARY_PATH (no clobber)
ltdl_prefix=""
# We're at the root of the module hierarchy.
modpath =
-# Compile psyntax and boot-9 first, so that we get the speed benefit in
-# the rest of the compilation. Also, if there is too much switching back
-# and forth between interpreted and compiled code, we end up using more
-# of the C stack than the interpreter would have; so avoid that by
-# putting these core modules first.
+BEGINNING_OF_TIME=198001010100
-SOURCES = \
- ice-9/psyntax-pp.scm \
- system/base/pmatch.scm system/base/syntax.scm \
- system/base/compile.scm system/base/language.scm \
- system/base/message.scm \
- \
- language/tree-il.scm \
- language/glil.scm language/assembly.scm \
- \
- $(SCHEME_LANG_SOURCES) \
- $(TREE_IL_LANG_SOURCES) \
- $(GLIL_LANG_SOURCES) \
- $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
- $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
- \
- $(ICE_9_SOURCES) \
- $(SRFI_SOURCES) \
- $(RNRS_SOURCES) \
- $(OOP_SOURCES) \
- $(SYSTEM_SOURCES) \
- $(SCRIPTS_SOURCES) \
- $(GHIL_LANG_SOURCES) \
- $(ECMASCRIPT_LANG_SOURCES) \
+$(GOBJECTS): ice-9/eval.go.stamp
+ice-9/eval.go.stamp: ice-9/eval.go
+ touch -t $(BEGINNING_OF_TIME) $(srcdir)/ice-9/eval.scm
+ touch -r $(srcdir)/ice-9/eval.scm ice-9/eval.go
+ touch -r $(srcdir)/ice-9/eval.scm ice-9/eval.go.stamp
+CLEANFILES += ice-9/eval.go ice-9/eval.go.stamp
+nobase_mod_DATA += ice-9/eval.scm
+nobase_ccache_DATA += ice-9/eval.go
+EXTRA_DIST += ice-9/eval.scm
+
+# We can compile these in any order, but it's fastest if we compile
+# psyntax and boot-9 first, then the compiler itself, then the rest of
+# the code.
+SOURCES = \
+ ice-9/psyntax-pp.scm \
+ ice-9/boot-9.scm \
+ \
+ language/tree-il.scm \
+ language/glil.scm \
+ language/assembly.scm \
+ $(TREE_IL_LANG_SOURCES) \
+ $(GLIL_LANG_SOURCES) \
+ $(ASSEMBLY_LANG_SOURCES) \
+ $(BYTECODE_LANG_SOURCES) \
+ $(OBJCODE_LANG_SOURCES) \
+ $(VALUE_LANG_SOURCES) \
+ $(SCHEME_LANG_SOURCES) \
+ $(SYSTEM_BASE_SOURCES) \
+ \
+ $(ICE_9_SOURCES) \
+ $(SRFI_SOURCES) \
+ $(RNRS_SOURCES) \
+ $(OOP_SOURCES) \
+ $(SYSTEM_SOURCES) \
+ $(SCRIPTS_SOURCES) \
+ $(ECMASCRIPT_LANG_SOURCES) \
+ $(ELISP_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES)
## test.scm is not currently installed.
-EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008
+EXTRA_DIST += \
+ ice-9/test.scm \
+ ice-9/compile-psyntax.scm \
+ ice-9/quasisyntax.scm \
+ ice-9/ChangeLog-2008
# We expect this to never be invoked when there is not already
# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
- language/scheme/compile-ghil.scm \
language/scheme/spec.scm \
language/scheme/compile-tree-il.scm \
- language/scheme/decompile-tree-il.scm \
- language/scheme/inline.scm
+ language/scheme/decompile-tree-il.scm
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
-GHIL_LANG_SOURCES = \
- language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
-
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \
language/glil/decompile-assembly.scm
language/ecmascript/compile-tree-il.scm \
language/ecmascript/spec.scm
+ELISP_LANG_SOURCES = \
+ language/elisp/lexer.scm \
+ language/elisp/parser.scm \
+ language/elisp/bindings.scm \
+ language/elisp/compile-tree-il.scm \
+ language/elisp/runtime.scm \
+ language/elisp/runtime/function-slot.scm \
+ language/elisp/runtime/macro-slot.scm \
+ language/elisp/runtime/value-slot.scm \
+ language/elisp/spec.scm
+
BRAINFUCK_LANG_SOURCES = \
language/brainfuck/parse.scm \
language/brainfuck/compile-scheme.scm \
scripts/read-rfc822.scm \
scripts/snarf-guile-m4-docs.scm
+SYSTEM_BASE_SOURCES = \
+ system/base/pmatch.scm \
+ system/base/syntax.scm \
+ system/base/compile.scm \
+ system/base/language.scm \
+ system/base/message.scm
+
ICE_9_SOURCES = \
- ice-9/boot-9.scm \
ice-9/r4rs.scm \
ice-9/r5rs.scm \
ice-9/and-let-star.scm \
NOCOMP_SOURCES = \
ice-9/gds-client.scm \
ice-9/psyntax.scm \
+ ice-9/quasisyntax.scm \
system/repl/describe.scm \
ice-9/debugger/command-loop.scm \
ice-9/debugger/commands.scm \
ice-9/debugger/trc.scm \
ice-9/debugger/utils.scm \
ice-9/debugging/example-fns.scm \
- ice-9/debugging/ice-9-debugger-extensions.scm \
ice-9/debugging/steps.scm \
ice-9/debugging/trace.scm \
ice-9/debugging/traps.scm \
-;;; installed-scm-file
+;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2009
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
(define pk peek)
+
(define (warn . stuff)
(with-output-to-port (current-error-port)
(lambda ()
(syntax-rules ()
((_ exp) (make-promise (lambda () exp)))))
+(include-from-path "ice-9/quasisyntax")
+
;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
;;; Please let the Guile developers know if you are using this macro.
;;;
(set! %load-hook %load-announce)
-;;; Returns the .go file corresponding to `name'. Does not search load
-;;; paths, only the fallback path. If the .go file is missing or out of
-;;; date, and autocompilation is enabled, will try autocompilation, just
-;;; as primitive-load-path does internally. primitive-load is
-;;; unaffected. Returns #f if autocompilation failed or was disabled.
-(define (autocompiled-file-name name)
- (catch #t
- (lambda ()
- (let* ((cfn ((@ (system base compile) compiled-file-name) name))
- (scmstat (stat name))
- (gostat (stat cfn #f)))
- (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
- cfn
- (begin
- (if gostat
- (format (current-error-port)
- ";;; note: source file ~a\n;;; newer than compiled ~a\n"
- name cfn))
- (cond
- (%load-should-autocompile
- (%warn-autocompilation-enabled)
- (format (current-error-port) ";;; compiling ~a\n" name)
- (let ((cfn ((@ (system base compile) compile-file) name)))
- (format (current-error-port) ";;; compiled ~a\n" cfn)
- cfn))
- (else #f))))))
- (lambda (k . args)
- (format (current-error-port)
- ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
- name k args)
- #f)))
-
(define (load name . reader)
+ ;; Returns the .go file corresponding to `name'. Does not search load
+ ;; paths, only the fallback path. If the .go file is missing or out of
+ ;; date, and autocompilation is enabled, will try autocompilation, just
+ ;; as primitive-load-path does internally. primitive-load is
+ ;; unaffected. Returns #f if autocompilation failed or was disabled.
+ (define (autocompiled-file-name name)
+ (catch #t
+ (lambda ()
+ (let* ((cfn ((@ (system base compile) compiled-file-name) name))
+ (scmstat (stat name))
+ (gostat (stat cfn #f)))
+ (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
+ cfn
+ (begin
+ (if gostat
+ (format (current-error-port)
+ ";;; note: source file ~a\n;;; newer than compiled ~a\n"
+ name cfn))
+ (cond
+ (%load-should-autocompile
+ (%warn-autocompilation-enabled)
+ (format (current-error-port) ";;; compiling ~a\n" name)
+ (let ((cfn ((@ (system base compile) compile-file) name
+ #:env (current-module))))
+ (format (current-error-port) ";;; compiled ~a\n" cfn)
+ cfn))
+ (else #f))))))
+ (lambda (k . args)
+ (format (current-error-port)
+ ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
+ name k args)
+ #f)))
(with-fluid* current-reader (and (pair? reader) (car reader))
(lambda ()
(let ((cfn (autocompiled-file-name name)))
\f
-;;; {Transcendental Functions}
-;;;
-;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
-;;; Written by Jerry D. Hedden, (C) FSF.
-;;; See the file `COPYING' for terms applying to this program.
-;;;
-
-(define expt
- (let ((integer-expt integer-expt))
- (lambda (z1 z2)
- (cond ((and (exact? z2) (integer? z2))
- (integer-expt z1 z2))
- ((and (real? z2) (real? z1) (>= z1 0))
- ($expt z1 z2))
- (else
- (exp (* z2 (log z1))))))))
-
-(define (sinh z)
- (if (real? z) ($sinh z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($sinh x) ($cos y))
- (* ($cosh x) ($sin y))))))
-(define (cosh z)
- (if (real? z) ($cosh z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($cosh x) ($cos y))
- (* ($sinh x) ($sin y))))))
-(define (tanh z)
- (if (real? z) ($tanh z)
- (let* ((x (* 2 (real-part z)))
- (y (* 2 (imag-part z)))
- (w (+ ($cosh x) ($cos y))))
- (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
-
-(define (asinh z)
- (if (real? z) ($asinh z)
- (log (+ z (sqrt (+ (* z z) 1))))))
-
-(define (acosh z)
- (if (and (real? z) (>= z 1))
- ($acosh z)
- (log (+ z (sqrt (- (* z z) 1))))))
-
-(define (atanh z)
- (if (and (real? z) (> z -1) (< z 1))
- ($atanh z)
- (/ (log (/ (+ 1 z) (- 1 z))) 2)))
-
-(define (sin z)
- (if (real? z) ($sin z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($sin x) ($cosh y))
- (* ($cos x) ($sinh y))))))
-(define (cos z)
- (if (real? z) ($cos z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($cos x) ($cosh y))
- (- (* ($sin x) ($sinh y)))))))
-(define (tan z)
- (if (real? z) ($tan z)
- (let* ((x (* 2 (real-part z)))
- (y (* 2 (imag-part z)))
- (w (+ ($cos x) ($cosh y))))
- (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
-
-(define (asin z)
- (if (and (real? z) (>= z -1) (<= z 1))
- ($asin z)
- (* -i (asinh (* +i z)))))
-
-(define (acos z)
- (if (and (real? z) (>= z -1) (<= z 1))
- ($acos z)
- (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
-
-(define (atan z . y)
- (if (null? y)
- (if (real? z) ($atan z)
- (/ (log (/ (- +i z) (+ +i z))) +2i))
- ($atan2 z (car y))))
-
-\f
-
;;; {Reader Extensions}
;;;
;;; Reader code for various "#c" forms.
;; NOTE: This binding is used in libguile/modules.c.
(define module-eval-closure (record-accessor module-type 'eval-closure))
-(define module-transformer (record-accessor module-type 'transformer))
+;; (define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
;; (define module-name (record-accessor module-type 'name)) wait until mods are booted
(define set-module-name! (record-modifier module-type 'name))
;; Make it possible to lookup the module from the environment.
;; This implementation is correct since an eval closure can belong
;; to maximally one module.
- (set-procedure-property! closure 'module module))))
+
+ ;; XXX: The following line introduces a circular reference that
+ ;; precludes garbage collection of modules with the current weak hash
+ ;; table semantics (see
+ ;; http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
+ ;; http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
+ ;; for details). Since it doesn't appear to be used (only in
+ ;; `scm_lookup_closure_module ()', which has 1 caller), we just comment
+ ;; it out.
+
+ ;(set-procedure-property! closure 'module module)
+ )))
\f
;; Import the default set of bindings (from the SCM module) in MODULE.
(module-use! module the-scm-module)))
+(define (make-fresh-user-module)
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+ m))
+
;; NOTE: This binding is used in libguile/modules.c.
;;
(define resolve-module
(apply make-stack #t save-stack primitive-eval #t 0 narrowing))
((load-stack)
(apply make-stack #t save-stack 0 #t 0 narrowing))
- ((tk-stack)
- (apply make-stack #t save-stack tk-stack-mark #t 0 narrowing))
((#t)
(apply make-stack #t save-stack 0 1 narrowing))
(else
;;; The default repl-reader function. We may override this if we've
;;; the readline library.
(define repl-reader
- (lambda (prompt)
+ (lambda (prompt . reader)
(display (if (string? prompt) prompt (prompt)))
(force-output)
(run-hook before-read-hook)
- ((or (fluid-ref current-reader) read) (current-input-port))))
+ ((or (and (pair? reader) (car reader))
+ (fluid-ref current-reader)
+ read)
+ (current-input-port))))
(define (scm-style-repl)
(display ";;; QUIT executed, repl exitting")
(newline)
(repl-report)))
- args))
-
- (-abort (lambda ()
- (if scm-repl-verbose
- (begin
- (display ";;; ABORT executed.")
- (newline)
- (repl-report)))
- (repl -read -eval -print))))
+ args)))
(let ((status (error-catching-repl -read
-eval
(defmacro name args . body)
(export-syntax name)))))
+;; And now for the most important macro.
+(define-syntax λ
+ (syntax-rules ()
+ ((_ formals body ...)
+ (lambda formals body ...))))
+
+\f
;; Export a local variable
;; This function is called from "modules.c". If you change it, be
(define %cond-expand-features
;; Adjust the above comment when changing this.
'(guile
+ guile-2
r5rs
srfi-0 ;; cond-expand itself
srfi-4 ;; homogenous numeric vectors
;;; Guile object channel
-;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2006, 2009 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
(define guile:eval eval)
(define eval
(if (= (car (procedure-property guile:eval 'arity)) 1)
- (lambda (x e) (guile:eval x))
+ (lambda (x e) (guile:eval x e))
guile:eval))
(define object->string
#:use-module (ice-9 debugger command-loop)
#:use-module (ice-9 debugger state)
#:use-module (ice-9 debugger utils)
+ #:use-module (ice-9 debugging traps)
#:use-module (ice-9 format)
#:export (debug-stack
debug
(apply default-pre-unwind-handler key args))
default-pre-unwind-handler)))
+;;; Also provide a `debug-trap' entry point. This maps from a
+;;; trap-context to a debug-stack call.
+
+(define-public (debug-trap trap-context)
+ "Invoke the Guile debugger to explore the stack at the specified @var{trap-context}."
+ (let* ((stack (tc:stack trap-context))
+ (flags1 (let ((trap-type (tc:type trap-context)))
+ (case trap-type
+ ((#:return #:error)
+ (list trap-type
+ (tc:return-value trap-context)))
+ (else
+ (list trap-type)))))
+ (flags (if (tc:continuation trap-context)
+ (cons #:continuable flags1)
+ flags1)))
+ (apply debug-stack stack flags)))
+
;;; (ice-9 debugger) ends here.
(define-module (ice-9 debugger command-loop)
#:use-module ((ice-9 debugger commands) :prefix debugger:)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 debugger state)
+ #:use-module (ice-9 debugging traps)
#:export (debugger-command-loop
debugger-command-loop-error
debugger-command-loop-quit)
(define-command-alias "where" "backtrace")
(define-command-alias "p" "evaluate")
(define-command-alias '("info" "stack") "backtrace")
+
+(define-command "continue" '() debugger:continue)
+
+(define-command "finish" '() debugger:finish)
+
+(define-command "step" '('optional exact-integer) debugger:step)
+
+(define-command "next" '('optional exact-integer) debugger:next)
;;;; (ice-9 debugger commands) -- debugger commands
-;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;; Copyright (C) 2002, 2006, 2009 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
#:use-module (ice-9 debugger)
#:use-module (ice-9 debugger state)
#:use-module (ice-9 debugger utils)
+ #:use-module (ice-9 debugging steps)
#:export (backtrace
evaluate
info-args
position
up
down
- frame))
+ frame
+ continue
+ finish
+ step
+ next))
(define (backtrace state n-frames)
"Print backtrace of all stack frames, or innermost COUNT frames.
(apply display-error stack (current-error-port) args)))))
(throw 'continue))
+;; FIXME: no longer working due to no more local-eval
(define (evaluate state expression)
"Evaluate an expression in the environment of the selected stack frame.
The expression must appear on the same line as the command, however it
(if n (set-stack-index! state (frame-number->index n (state-stack state))))
(write-state-short state))
+(define (assert-continuable state)
+ ;; Check that debugger is in a state where `continuing' makes sense.
+ ;; If not, signal an error.
+ (or (memq #:continuable (state-flags state))
+ (user-error "This debug session is not continuable.")))
+
+(define (continue state)
+ "Tell the program being debugged to continue running. (In fact this is
+the same as the @code{quit} command, because it exits the debugger
+command loop and so allows whatever code it was that invoked the
+debugger to continue.)"
+ (assert-continuable state)
+ (throw 'exit-debugger))
+
+(define (finish state)
+ "Continue until evaluation of the current frame is complete, and
+print the result obtained."
+ (assert-continuable state)
+ (at-exit (- (stack-length (state-stack state))
+ (state-index state))
+ (list trace-trap debug-trap))
+ (continue state))
+
+(define (step state n)
+ "Tell the debugged program to do @var{n} more steps from its current
+position. One @dfn{step} means executing until the next frame entry
+or exit of any kind. @var{n} defaults to 1."
+ (assert-continuable state)
+ (at-step debug-trap (or n 1))
+ (continue state))
+
+(define (next state n)
+ "Tell the debugged program to do @var{n} more steps from its current
+position, but only counting frame entries and exits where the
+corresponding source code comes from the same file as the current
+stack frame. (See @ref{Step Traps} for the details of how this
+works.) If the current stack frame has no source code, the effect of
+this command is the same as of @code{step}. @var{n} defaults to 1."
+ (assert-continuable state)
+ (at-step debug-trap
+ (or n 1)
+ (frame-file-name (stack-ref (state-stack state)
+ (state-index state)))
+ (if (memq #:return (state-flags state))
+ #f
+ (- (stack-length (state-stack state)) (state-index state))))
+ (continue state))
+
;;; (ice-9 debugger commands) ends here.
#:use-module (ice-9 optargs)
#:use-module (ice-9 regex)
#:use-module (oop goops)
- #:use-module (ice-9 debugging ice-9-debugger-extensions)
#:use-module (ice-9 debugging traps)
#:use-module (ice-9 debugging trc)
#:use-module (srfi srfi-1)
(define-module (ice-9 debugging trace)
#:use-module (ice-9 debug)
#:use-module (ice-9 debugger)
- #:use-module (ice-9 debugging ice-9-debugger-extensions)
+ #:use-module (ice-9 debugger utils)
#:use-module (ice-9 debugging steps)
#:use-module (ice-9 debugging traps)
#:export (trace-trap
trace-at-exit
trace-until-exit))
-(cond ((string>=? (version) "1.7")
- (use-modules (ice-9 debugger utils))))
-
(define trace-format-string #f)
(define trace-arg-procs #f)
;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface
-;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
+;;; Copyright (C) 2002, 2004, 2009 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Neil Jerram
;;;
;;;; This library is free software; you can redistribute it and/or
(define-module (ice-9 debugging traps)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 weak-vector)
#:use-module (oop goops)
#:use-module (oop goops describe)
#:use-module (ice-9 debugging trc)
;; "(trc " to find other symbols that can be passed to trc-add.
;; (trc-add 'after-gc-hook)
-;; In Guile 1.7 onwards, weak-vector and friends are provided by the
-;; (ice-9 weak-vector) module.
-(cond ((string>=? (version) "1.7")
- (use-modules (ice-9 weak-vector))))
-
;;; The current low level traps interface is as follows.
;;;
;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled
(= (caddr trap-location) (slot-ref trap 'column))))))
;; (trap-here EXPRESSION . OPTIONS)
+;; FIXME: no longer working due to no mmacros, no local-eval
(define trap-here
(procedure->memoizing-macro
(lambda (expr env)
(trap-disable 'traps)
(thunk))))
-(define guile-trap-features
- ;; Helper procedure, to test whether a specific possible Guile
- ;; feature is supported.
- (let ((supported?
- (lambda (test-feature)
- (case test-feature
- ((tweaking)
- ;; Tweaking is supported if the description of the cheap
- ;; traps option includes the word "obsolete", or if the
- ;; option isn't there any more.
- (and (string>=? (version) "1.7")
- (let ((cheap-opt-desc
- (assq 'cheap (debug-options-interface 'help))))
- (or (not cheap-opt-desc)
- (string-match "obsolete" (caddr cheap-opt-desc))))))
- (else
- (error "Unexpected feature name:" test-feature))))))
- ;; Compile the list of actually supported features from all
- ;; possible features.
- (let loop ((possible-features '(tweaking))
- (actual-features '()))
- (if (null? possible-features)
- (reverse! actual-features)
- (let ((test-feature (car possible-features)))
- (loop (cdr possible-features)
- (if (supported? test-feature)
- (cons test-feature actual-features)
- actual-features)))))))
+(define guile-trap-features '(tweaking))
;; Make sure that traps are enabled.
(trap-enable 'traps)
`(begin *unspecified* . ,exps)))
(else
`(begin))))
+
+(read-hash-extend
+ #\y
+ (lambda (c port)
+ (issue-deprecation-warning
+ "The `#y' bitvector syntax is deprecated. Use `#*' instead.")
+ (let ((x (read port)))
+ (cond
+ ((list? x)
+ (list->bitvector
+ (map (lambda (x)
+ (cond ((zero? x) #f)
+ ((eqv? x 1) #t)
+ (else (error "invalid #y element" x))))
+ x)))
+ (else
+ (error "#y needs to be followed by a list" x))))))
+
+(define (unmemoize-expr . args)
+ (issue-deprecation-warning
+ "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
+ (apply unmemoize-expression args))
+
+(define ($asinh z) (asinh z))
+(define ($acosh z) (acosh z))
+(define ($atanh z) (atanh z))
+(define ($sqrt z) (sqrt z))
+(define ($abs z) (abs z))
+(define ($exp z) (exp z))
+(define ($log z) (log z))
+(define ($sin z) (sin z))
+(define ($cos z) (cos z))
+(define ($tan z) (tan z))
+(define ($asin z) (asin z))
+(define ($acos z) (acos z))
+(define ($atan z) (atan z))
+(define ($sinh z) (sinh z))
+(define ($cosh z) (cosh z))
+(define ($tanh z) (tanh z))
+(define (closure? x)
+ (issue-deprecation-warning
+ "`closure?' is deprecated. Use `procedure?' instead.")
+ (procedure? x))
-;;;; Copyright (C) 2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000,2001, 2002, 2003, 2006, 2009 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
(and (macro? object)
(object-documentation (macro-transformer object)))
(and (procedure? object)
- (not (closure? object))
(procedure-name object)
(let ((docstring (search-documentation-files
(procedure-name object))))
-;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006, 2009 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
msg)
msg)))
+;; FIXME: no longer working due to removal of local-eval
(define (emacs-frame-eval frame form)
(let ((source (get-frame-source frame)))
(if source
--- /dev/null
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;;; Copyright (C) 2009
+;;;; 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
+;;;;
+
+\f
+
+;;; Commentary:
+
+;;; Scheme eval, written in Scheme.
+;;;
+;;; Expressions are first expanded, by the syntax expander (i.e.
+;;; psyntax), then memoized into internal forms. The evaluator itself
+;;; only operates on the internal forms ("memoized expressions").
+;;;
+;;; Environments are represented as linked lists of the form (VAL ... .
+;;; MOD). If MOD is #f, it means the environment was captured before
+;;; modules were booted. If MOD is the literal value '(), we are
+;;; evaluating at the top level, and so should track changes to the
+;;; current module.
+;;;
+;;; Evaluate this in Emacs to make code indentation work right:
+;;;
+;;; (put 'memoized-expression-case 'scheme-indent-function 1)
+;;;
+
+;;; Code:
+
+\f
+
+(eval-when (compile)
+ (define-syntax capture-env
+ (syntax-rules ()
+ ((_ env)
+ (if (null? env)
+ (current-module)
+ (if (not env)
+ ;; the and current-module checks that modules are booted,
+ ;; and thus the-root-module is defined
+ (and (current-module) the-root-module)
+ env)))))
+
+ ;; This macro could be more straightforward if the compiler had better
+ ;; copy propagation. As it is we do some copy propagation by hand.
+ (define-syntax mx-bind
+ (lambda (x)
+ (syntax-case x ()
+ ((_ data () body)
+ #'body)
+ ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
+ #'(let ((a (car data))
+ (b (cdr data)))
+ body))
+ ((_ data (a . b) body) (identifier? #'a)
+ #'(let ((a (car data))
+ (xb (cdr data)))
+ (mx-bind xb b body)))
+ ((_ data (a . b) body)
+ #'(let ((xa (car data))
+ (xb (cdr data)))
+ (mx-bind xa a (mx-bind xb b body))))
+ ((_ data v body) (identifier? #'v)
+ #'(let ((v data))
+ body)))))
+
+ ;; The resulting nested if statements will be an O(n) dispatch. Once
+ ;; we compile `case' effectively, this situation will improve.
+ (define-syntax mx-match
+ (lambda (x)
+ (syntax-case x (quote)
+ ((_ mx data tag)
+ #'(error "what" mx))
+ ((_ mx data tag (('type pat) body) c* ...)
+ #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
+ (error "not a typecode" #'type)))
+ (mx-bind data pat body)
+ (mx-match mx data tag c* ...))))))
+
+ (define-syntax memoized-expression-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ mx c ...)
+ #'(let ((tag (memoized-expression-typecode mx))
+ (data (memoized-expression-data mx)))
+ (mx-match mx data tag c ...)))))))
+
+
+(define primitive-eval
+ (let ()
+ ;; The "engine". EXP is a memoized expression.
+ (define (eval exp env)
+ (memoized-expression-case exp
+ (('begin (first . rest))
+ (let lp ((first first) (rest rest))
+ (if (null? rest)
+ (eval first env)
+ (begin
+ (eval first env)
+ (lp (car rest) (cdr rest))))))
+
+ (('if (test consequent . alternate))
+ (if (eval test env)
+ (eval consequent env)
+ (eval alternate env)))
+
+ (('let (inits . body))
+ (let lp ((inits inits) (new-env (capture-env env)))
+ (if (null? inits)
+ (eval body new-env)
+ (lp (cdr inits)
+ (cons (eval (car inits) env) new-env)))))
+
+ (('lambda (nreq rest? . body))
+ (let ((env (capture-env env)))
+ (lambda args
+ (let lp ((env env) (nreq nreq) (args args))
+ (if (zero? nreq)
+ (eval body
+ (if rest?
+ (cons args env)
+ (if (not (null? args))
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f)
+ env)))
+ (if (null? args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f)
+ (lp (cons (car args) env)
+ (1- nreq)
+ (cdr args))))))))
+
+ (('quote x)
+ x)
+
+ (('define (name . x))
+ (define! name (eval x env)))
+
+ (('apply (f args))
+ (apply (eval f env) (eval args env)))
+
+ (('call (f . args))
+ (let ((proc (eval f env)))
+ (let eval-args ((in args) (out '()))
+ (if (null? in)
+ (apply proc (reverse out))
+ (eval-args (cdr in)
+ (cons (eval (car in) env) out))))))
+
+ (('call/cc proc)
+ (call/cc (eval proc env)))
+
+ (('call-with-values (producer . consumer))
+ (call-with-values (eval producer env)
+ (eval consumer env)))
+
+ (('lexical-ref n)
+ (let lp ((n n) (env env))
+ (if (zero? n)
+ (car env)
+ (lp (1- n) (cdr env)))))
+
+ (('lexical-set! (n . x))
+ (let ((val (eval x env)))
+ (let lp ((n n) (env env))
+ (if (zero? n)
+ (set-car! env val)
+ (lp (1- n) (cdr env))))))
+
+ (('toplevel-ref var-or-sym)
+ (variable-ref
+ (if (variable? var-or-sym)
+ var-or-sym
+ (let lp ((env env))
+ (if (pair? env)
+ (lp (cdr env))
+ (memoize-variable-access! exp (capture-env env)))))))
+
+ (('toplevel-set! (var-or-sym . x))
+ (variable-set!
+ (if (variable? var-or-sym)
+ var-or-sym
+ (let lp ((env env))
+ (if (pair? env)
+ (lp (cdr env))
+ (memoize-variable-access! exp (capture-env env)))))
+ (eval x env)))
+
+ (('module-ref var-or-spec)
+ (variable-ref
+ (if (variable? var-or-spec)
+ var-or-spec
+ (memoize-variable-access! exp #f))))
+
+ (('module-set! (x . var-or-spec))
+ (variable-set!
+ (if (variable? var-or-spec)
+ var-or-spec
+ (memoize-variable-access! exp #f))
+ (eval x env)))))
+
+ ;; primitive-eval
+ (lambda (exp)
+ "Evaluate @var{exp} in the current module."
+ (eval
+ (memoize-expression ((or (module-transformer (current-module))
+ (lambda (x) x))
+ exp))
+ '()))))
+
-;;;; ftw.scm --- filesystem tree walk
+;;;; ftw.scm --- file system tree walk
;;;; Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
;;;;
;; entered directory.
;;
;; * Procedure: (ftw filename proc . options)
-;; Do a filesystem tree walk starting at FILENAME using PROC.
+;; Do a file system tree walk starting at FILENAME using PROC.
;;
;; The `ftw' procedure calls the callback procedure given in the
;; parameter PROC for every item which is found in the directory
;; returned as the return value of `ftw'.
;;
;; * Procedure: (nftw filename proc . control-flags)
-;; Do a new-style filesystem tree walk starting at FILENAME using PROC.
+;; Do a new-style file system tree walk starting at FILENAME using PROC.
;; Various optional CONTROL-FLAGS alter the default behavior.
;;
;; The `nftw' procedures works like the `ftw' procedures. It calls
;;
;; mount'
;; The callback procedure is only called for items which are on
-;; the same mounted filesystem as the directory given as the
+;; the same mounted file system as the directory given as the
;; FILENAME parameter to `nftw'.
;;
;; chdir'
run-utility
gds-accept-input))
-(cond ((string>=? (version) "1.7")
- (use-modules (ice-9 debugger utils)))
- (else
- (define the-ice-9-debugger-module (resolve-module '(ice-9 debugger)))
- (module-export! the-ice-9-debugger-module
- '(source-position
- write-frame-short/application
- write-frame-short/expression
- write-frame-args-long
- write-frame-long))))
+(use-modules (ice-9 debugger utils))
(use-modules (ice-9 debugger))
(define (connect-to-gds . application-name)
(or gds-port
- (begin
+ (let ((gds-unix-socket-name (getenv "GDS_UNIX_SOCKET_NAME")))
(set! gds-port
- (or (let ((s (socket PF_INET SOCK_STREAM 0))
- (SOL_TCP 6)
- (TCP_NODELAY 1))
- (setsockopt s SOL_TCP TCP_NODELAY 1)
- (catch #t
- (lambda ()
- (connect s AF_INET (inet-aton "127.0.0.1") 8333)
- s)
- (lambda _ #f)))
- (let ((s (socket PF_UNIX SOCK_STREAM 0)))
- (catch #t
- (lambda ()
- (connect s AF_UNIX "/tmp/.gds_socket")
- s)
- (lambda _ #f)))
+ (or (and gds-unix-socket-name
+ (false-if-exception
+ (let ((s (socket PF_UNIX SOCK_STREAM 0)))
+ (connect s AF_UNIX gds-unix-socket-name)
+ s)))
+ (false-if-exception
+ (let ((s (socket PF_INET SOCK_STREAM 0))
+ (SOL_TCP 6)
+ (TCP_NODELAY 1))
+ (setsockopt s SOL_TCP TCP_NODELAY 1)
+ (connect s AF_INET (inet-aton "127.0.0.1") 8333)
+ s))
(error "Couldn't connect to GDS by TCP or Unix domain socket")))
(write-form (list 'name (getpid) (apply client-name application-name))))))
(else
(format #f "~A (PID ~A)" arg (getpid))))))))
-(if (not (defined? 'make-mutex))
- (begin
- (define (make-mutex) #f)
- (define lock-mutex noop)
- (define unlock-mutex noop)))
+;;(if (not (defined? 'make-mutex))
+;; (begin
+;; (define (make-mutex) #f)
+;; (define lock-mutex noop)
+;; (define unlock-mutex noop)))
(define write-mutex (make-mutex))
erf))
flags)))
+;; FIXME: the new evaluator breaks this, by removing local-eval. Need to
+;; figure out our story in this regard.
(define (eval-in-frame stack index expr)
(write-form
(list 'eval-result
(define connection->id (make-object-property))
-(define (run-server port-or-path)
-
- (or (integer? port-or-path)
- (string? port-or-path)
- (error "port-or-path should be an integer (port number) or a string (file name)"
- port-or-path))
-
- (let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX)
- SOCK_STREAM
- 0)))
-
- ;; Initialize server socket.
- (if (integer? port-or-path)
- (begin
- (setsockopt server SOL_SOCKET SO_REUSEADDR 1)
- (bind server AF_INET INADDR_ANY port-or-path))
- (begin
- (catch #t
- (lambda () (delete-file port-or-path))
- (lambda _ #f))
- (bind server AF_UNIX port-or-path)))
-
- ;; Start listening.
- (listen server 5)
+(define (run-server unix-socket-name tcp-port)
+ (let ((unix-server (socket PF_UNIX SOCK_STREAM 0))
+ (tcp-server (socket PF_INET SOCK_STREAM 0)))
+
+ ;; Bind and start listening on the Unix domain socket.
+ (false-if-exception (delete-file unix-socket-name))
+ (bind unix-server AF_UNIX unix-socket-name)
+ (listen unix-server 5)
+
+ ;; Bind and start listening on the TCP socket.
+ (setsockopt tcp-server SOL_SOCKET SO_REUSEADDR 1)
+ (false-if-exception (bind tcp-server AF_INET INADDR_ANY tcp-port))
+ (listen tcp-server 5)
+
+ ;; Main loop.
(let loop ((clients '()) (readable-sockets '()))
(define (do-read port)
(cond ((eq? port (current-input-port))
(do-read-from-ui))
- ((eq? port server)
- (accept-new-client))
+ ((eq? port unix-server)
+ (accept-new-client unix-server))
+ ((eq? port tcp-server)
+ (accept-new-client tcp-server))
(else
(do-read-from-client port))))
(trc "client not found")))
clients)
- (define (accept-new-client)
+ (define (accept-new-client server)
(let ((new-port (car (accept server))))
;; Read the client's ID.
(let ((name-form (read new-port)))
;;(trc 'readable-sockets readable-sockets)
(if (null? readable-sockets)
- (loop clients (car (select (cons (current-input-port)
- (cons server clients))
+ (loop clients (car (select (cons* (current-input-port)
+ unix-server
+ tcp-server
+ clients)
'()
'())))
(loop (do-read (car readable-sockets)) (cdr readable-sockets))))))
;;;; i18n.scm --- internationalization support
-;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009 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
-;;; Author: Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Author: Ludovic Courtès <ludo@gnu.org>
;;; Commentary:
;;;
(eval-when (eval load compile)
- (load-extension "libguile-i18n-v-0" "scm_init_i18n"))
+ (load-extension "libguile" "scm_init_i18n"))
\f
;;;
;;;; optargs.scm -- support for optional arguments
;;;;
-;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009 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
;;; Code:
(define-module (ice-9 optargs)
- :export-syntax (let-optional
- let-optional*
- let-keywords
- let-keywords*
- define* lambda*
- define*-public
- defmacro*
- defmacro*-public))
+ #:use-module (system base pmatch)
+ #:re-export (lambda* define*)
+ #:export (let-optional
+ let-optional*
+ let-keywords
+ let-keywords*
+ define*-public
+ defmacro*
+ defmacro*-public))
;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body
;; bound to whatever may have been left of rest-arg.
;;
-(defmacro let-optional (REST-ARG BINDINGS . BODY)
- (let-optional-template REST-ARG BINDINGS BODY 'let))
-
-(defmacro let-optional* (REST-ARG BINDINGS . BODY)
- (let-optional-template REST-ARG BINDINGS BODY 'let*))
-
+(define (vars&inits bindings)
+ (let lp ((bindings bindings) (vars '()) (inits '()))
+ (syntax-case bindings ()
+ (()
+ (values (reverse vars) (reverse inits)))
+ (((v init) . rest) (identifier? #'v)
+ (lp #'rest (cons #'v vars) (cons #'init inits)))
+ ((v . rest) (identifier? #'v)
+ (lp #'rest (cons #'v vars) (cons #'#f inits))))))
+
+(define-syntax let-optional
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (n+1 (1+ (length vars)))
+ (vars (append vars (list #'rest-arg)))
+ ((t ...) (generate-temporaries vars))
+ ((i ...) inits))
+ #'(let ((t (lambda vars i))
+ ...)
+ (apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 n n n+1 #f '())
+ (list t ...)
+ rest-arg)
+ (error "sth" rest-arg)))))))))))
+
+(define-syntax let-optional*
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (n+1 (1+ (length vars)))
+ (vars (append vars (list #'rest-arg)))
+ ((i ...) inits))
+ #'(apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 n n n+1 #f '())
+ (list (lambda vars i) ...)
+ rest-arg)
+ (error "sth" rest-arg))))))))))
;; let-keywords rest-arg allow-other-keys? (binding ...) . body
;;
-(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
- (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
-
-(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
- (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
-
-
-;; some utility procedures for implementing the various let-forms.
-
-(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
- (let ((bindings (map (lambda (x)
- (if (list? x)
- x
- (list x #f)))
- BINDINGS)))
- `(,let-type ,(map proc bindings) ,@BODY)))
-
-(define (let-optional-template REST-ARG BINDINGS BODY let-type)
- (if (null? BINDINGS)
- `(let () ,@BODY)
- (let-o-k-template REST-ARG BINDINGS BODY let-type
- (lambda (optional)
- `(,(car optional)
- (cond
- ((not (null? ,REST-ARG))
- (let ((result (car ,REST-ARG)))
- ,(list 'set! REST-ARG
- `(cdr ,REST-ARG))
- result))
- (else
- ,(cadr optional))))))))
-
-(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
- (if (null? BINDINGS)
- `(let () ,@BODY)
- (let* ((kb-list-gensym (gensym "kb:G"))
- (bindfilter (lambda (key)
- `(,(car key)
- (cond
- ((assq ',(car key) ,kb-list-gensym)
- => cdr)
- (else
- ,(cadr key)))))))
- `(let ((,kb-list-gensym ((@@ (ice-9 optargs) rest-arg->keyword-binding-list)
- ,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
- BINDINGS)
- ,ALLOW-OTHER-KEYS?)))
- ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
-
-
-(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
- (if (null? rest-arg)
- '()
- (let loop ((first (car rest-arg))
- (rest (cdr rest-arg))
- (accum '()))
- (let ((next (lambda (a)
- (if (null? (cdr rest))
- a
- (loop (cadr rest) (cddr rest) a)))))
- (if (keyword? first)
- (cond
- ((memq first keywords)
- (if (null? rest)
- (error "Keyword argument has no value.")
- (next (cons (cons (keyword->symbol first)
- (car rest)) accum))))
- ((not allow-other-keys?)
- (error "Unknown keyword in arguments."))
- (else (if (null? rest)
- accum
- (next accum))))
- (if (null? rest)
- accum
- (loop (car rest) (cdr rest) accum)))))))
-
+(define-syntax let-keywords
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (vars vars)
+ (ivars (generate-temporaries vars))
+ ((kw ...) (map symbol->keyword
+ (map syntax->datum vars)))
+ ((idx ...) (iota (length vars)))
+ ((t ...) (generate-temporaries vars))
+ ((i ...) inits))
+ #'(let ((t (lambda ivars i))
+ ...)
+ (apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
+ (list t ...)
+ rest-arg)
+ (error "sth" rest-arg))))))))
+ ((_ rest-arg aok (binding ...) b0 b1 ...)
+ #'(let ((r rest-arg))
+ (let-keywords r aok (binding ...) b0 b1 ...))))))
+
+(define-syntax let-keywords*
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (vars vars)
+ ((kw ...) (map symbol->keyword
+ (map syntax->datum vars)))
+ ((idx ...) (iota (length vars)))
+ ((i ...) inits))
+ #'(apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
+ (list (lambda vars i) ...)
+ rest-arg)
+ (error "sth" rest-arg)))))))
+ ((_ rest-arg aok (binding ...) b0 b1 ...)
+ #'(let ((r rest-arg))
+ (let-keywords* r aok (binding ...) b0 b1 ...))))))
;; lambda* args . body
;; lambda extended for optional and keyword arguments
;; Lisp dialects.
-(defmacro lambda* (ARGLIST . BODY)
- (parse-arglist
- ARGLIST
- (lambda (non-optional-args optionals keys aok? rest-arg)
- ;; Check for syntax errors.
- (if (not (every? symbol? non-optional-args))
- (error "Syntax error in fixed argument declaration."))
- (if (not (every? ext-decl? optionals))
- (error "Syntax error in optional argument declaration."))
- (if (not (every? ext-decl? keys))
- (error "Syntax error in keyword argument declaration."))
- (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
- (error "Syntax error in rest argument declaration."))
- ;; generate the code.
- (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
- (lambda-gensym (gensym "lambda*:L")))
- (if (not (and (null? optionals) (null? keys)))
- `(let ((,lambda-gensym
- (lambda (,@non-optional-args . ,rest-gensym)
- ;; Make sure that if the proc had a docstring, we put it
- ;; here where it will be visible.
- ,@(if (and (not (null? BODY))
- (string? (car BODY)))
- (list (car BODY))
- '())
- (let-optional*
- ,rest-gensym
- ,optionals
- (let-keywords* ,rest-gensym
- ,aok?
- ,keys
- ,@(if (and (not rest-arg) (null? keys))
- `((if (not (null? ,rest-gensym))
- (error "Too many arguments.")))
- '())
- (let ()
- ,@BODY))))))
- (set-procedure-property! ,lambda-gensym 'arglist
- '(,non-optional-args
- ,optionals
- ,keys
- ,aok?
- ,rest-arg))
- ,lambda-gensym)
- `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
- ,@BODY))))))
-
-
-(define (every? pred lst)
- (or (null? lst)
- (and (pred (car lst))
- (every? pred (cdr lst)))))
-
-(define (ext-decl? obj)
- (or (symbol? obj)
- (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
-
-;; XXX - not tail recursive
-(define (improper-list-copy obj)
- (if (pair? obj)
- (cons (car obj) (improper-list-copy (cdr obj)))
- obj))
-
-(define (parse-arglist arglist cont)
- (define (split-list-at val lst cont)
- (cond
- ((memq val lst)
- => (lambda (pos)
- (if (memq val (cdr pos))
- (error (with-output-to-string
- (lambda ()
- (map display `(,val
- " specified more than once in argument list.")))))
- (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
- (else (cont lst '() #f))))
- (define (parse-opt-and-fixed arglist keys aok? rest cont)
- (split-list-at
- #:optional arglist
- (lambda (before after split?)
- (if (and split? (null? after))
- (error "#:optional specified but no optional arguments declared.")
- (cont before after keys aok? rest)))))
- (define (parse-keys arglist rest cont)
- (split-list-at
- #:allow-other-keys arglist
- (lambda (aok-before aok-after aok-split?)
- (if (and aok-split? (not (null? aok-after)))
- (error "#:allow-other-keys not at end of keyword argument declarations.")
- (split-list-at
- #:key aok-before
- (lambda (key-before key-after key-split?)
- (cond
- ((and aok-split? (not key-split?))
- (error "#:allow-other-keys specified but no keyword arguments declared."))
- (key-split?
- (cond
- ((null? key-after) (error "#:key specified but no keyword arguments declared."))
- ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
- (else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
- (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
- (define (parse-rest arglist cont)
- (cond
- ((null? arglist) (cont '() '() '() #f #f))
- ((not (pair? arglist)) (cont '() '() '() #f arglist))
- ((not (list? arglist))
- (let* ((copy (improper-list-copy arglist))
- (lp (last-pair copy))
- (ra (cdr lp)))
- (set-cdr! lp '())
- (if (memq #:rest copy)
- (error "Cannot specify both #:rest and dotted rest argument.")
- (parse-keys copy ra cont))))
- (else (split-list-at
- #:rest arglist
- (lambda (before after split?)
- (if split?
- (case (length after)
- ((0) (error "#:rest not followed by argument."))
- ((1) (parse-keys before (car after) cont))
- (else (error "#:rest argument must be declared last.")))
- (parse-keys before #f cont)))))))
-
- (parse-rest arglist cont))
-
-
-
;; define* args . body
;; define*-public args . body
;; define and define-public extended for optional and keyword arguments
;;
;; define* and define*-public support optional arguments with
-;; a similar syntax to lambda*. They also support arbitrary-depth
-;; currying, just like Guile's define. Some examples:
+;; a similar syntax to lambda*. Some examples:
;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
;; defines a procedure x with a fixed argument y, an optional agument
;; a, another optional argument z with default value 3, a keyword argument w,
;; and a rest argument u.
-;; (define-public* ((foo #:optional bar) #:optional baz) '())
-;; This illustrates currying. A procedure foo is defined, which,
-;; when called with an optional argument bar, returns a procedure that
-;; takes an optional argument baz.
;;
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*.
-(defmacro define* (ARGLIST . BODY)
- (define*-guts 'define ARGLIST BODY))
-
-(defmacro define*-public (ARGLIST . BODY)
- (define*-guts 'define-public ARGLIST BODY))
-
-;; The guts of define* and define*-public.
-(define (define*-guts DT ARGLIST BODY)
- (define (nest-lambda*s arglists)
- (if (null? arglists)
- BODY
- `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
- (define (define*-guts-helper ARGLIST arglists)
- (let ((first (car ARGLIST))
- (al (cons (cdr ARGLIST) arglists)))
- (if (symbol? first)
- `(,DT ,first ,@(nest-lambda*s al))
- (define*-guts-helper first al))))
- (if (symbol? ARGLIST)
- `(,DT ,ARGLIST ,@BODY)
- (define*-guts-helper ARGLIST '())))
-
+(define-syntax define*-public
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (define-public id (lambda* args b0 b1 ...)))))
;; defmacro* name args . body
;; semantics. Here is an example of a macro with an optional argument:
;; (defmacro* transmorgify (a #:optional b)
-(defmacro defmacro* (NAME ARGLIST . BODY)
- `(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY)))
-
-(defmacro defmacro*-public (NAME ARGLIST . BODY)
- `(begin
- (defmacro* ,NAME ,ARGLIST ,@BODY)
- (export-syntax ,NAME)))
-
-;;; optargs.scm ends here
+(define-syntax defmacro*
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (defmacro id (lambda* args b0 b1 ...)))))
+(define-syntax defmacro*-public
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (begin
+ (defmacro id (lambda* args b0 b1 ...))
+ (export-syntax id)))))
+
+;;; Support for optional & keyword args with the interpreter.
+(define *uninitialized* (list 'uninitialized))
+(define (parse-lambda-case spec inits args)
+ (pmatch spec
+ ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+ (define (req args prev tail n)
+ (cond
+ ((zero? n)
+ (if prev (set-cdr! prev '()))
+ (let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
+ (opt (if prev (append! args slots-tail) slots-tail)
+ slots-tail tail nopt inits)))
+ ((null? tail)
+ #f) ;; fail
+ (else
+ (req args tail (cdr tail) (1- n)))))
+ (define (opt slots slots-tail args-tail n inits)
+ (cond
+ ((zero? n)
+ (rest-or-key slots slots-tail args-tail inits rest-idx))
+ ((null? args-tail)
+ (set-car! slots-tail (apply (car inits) slots))
+ (opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
+ (else
+ (set-car! slots-tail (car args-tail))
+ (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
+ (define (rest-or-key slots slots-tail args-tail inits rest-idx)
+ (cond
+ (rest-idx
+ ;; it has to be this way, vars are allocated in this order
+ (set-car! slots-tail args-tail)
+ (if (pair? kw-indices)
+ (permissive-keys slots (cdr slots-tail) args-tail inits)
+ (rest-or-key slots (cdr slots-tail) '() inits #f)))
+ ((pair? kw-indices)
+ ;; fail early here, because once we're in keyword land we throw
+ ;; errors instead of failing
+ (and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
+ (key slots slots-tail args-tail inits)))
+ ((pair? args-tail)
+ #f) ;; fail
+ (else
+ slots)))
+ (define (permissive-keys slots slots-tail args-tail inits)
+ (cond
+ ((null? args-tail)
+ (if (null? inits)
+ slots
+ (begin
+ (if (eq? (car slots-tail) *uninitialized*)
+ (set-car! slots-tail (apply (car inits) slots)))
+ (permissive-keys slots (cdr slots-tail) '() (cdr inits)))))
+ ((not (keyword? (car args-tail)))
+ (permissive-keys slots slots-tail (cdr args-tail) inits))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ (assq-ref kw-indices (car args-tail)))
+ => (lambda (i)
+ (list-set! slots i (cadr args-tail))
+ (permissive-keys slots slots-tail (cddr args-tail) inits)))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ allow-other-keys?)
+ (permissive-keys slots slots-tail (cddr args-tail) inits))
+ (else (error "unrecognized keyword" args-tail))))
+ (define (key slots slots-tail args-tail inits)
+ (cond
+ ((null? args-tail)
+ (if (null? inits)
+ slots
+ (begin
+ (if (eq? (car slots-tail) *uninitialized*)
+ (set-car! slots-tail (apply (car inits) slots)))
+ (key slots (cdr slots-tail) '() (cdr inits)))))
+ ((not (keyword? (car args-tail)))
+ (if rest-idx
+ ;; no error checking, everything goes to the rest..
+ (key slots slots-tail '() inits)
+ (error "bad keyword argument list" args-tail)))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ (assq-ref kw-indices (car args-tail)))
+ => (lambda (i)
+ (list-set! slots i (cadr args-tail))
+ (key slots slots-tail (cddr args-tail) inits)))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ allow-other-keys?)
+ (key slots slots-tail (cddr args-tail) inits))
+ (else (error "unrecognized keyword" args-tail))))
+ (let ((args (list-copy args)))
+ (req args #f args nreq)))
+ (else (error "unexpected spec" spec))))
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f)
-(letrec ((#{and-map*\ 1199}#
- (lambda (#{f\ 1239}# #{first\ 1238}# . #{rest\ 1237}#)
- (let ((#{t\ 1240}# (null? #{first\ 1238}#)))
- (if #{t\ 1240}#
- #{t\ 1240}#
- (if (null? #{rest\ 1237}#)
- (letrec ((#{andmap\ 1241}#
- (lambda (#{first\ 1242}#)
- (let ((#{x\ 1243}# (car #{first\ 1242}#))
- (#{first\ 1244}# (cdr #{first\ 1242}#)))
- (if (null? #{first\ 1244}#)
- (#{f\ 1239}# #{x\ 1243}#)
- (if (#{f\ 1239}# #{x\ 1243}#)
- (#{andmap\ 1241}# #{first\ 1244}#)
+(letrec ((#{and-map*\ 3695}#
+ (lambda (#{f\ 3733}# #{first\ 3734}# . #{rest\ 3735}#)
+ (let ((#{t\ 3736}# (null? #{first\ 3734}#)))
+ (if #{t\ 3736}#
+ #{t\ 3736}#
+ (if (null? #{rest\ 3735}#)
+ (letrec ((#{andmap\ 3737}#
+ (lambda (#{first\ 3738}#)
+ (let ((#{x\ 3739}# (car #{first\ 3738}#))
+ (#{first\ 3740}# (cdr #{first\ 3738}#)))
+ (if (null? #{first\ 3740}#)
+ (#{f\ 3733}# #{x\ 3739}#)
+ (if (#{f\ 3733}# #{x\ 3739}#)
+ (#{andmap\ 3737}# #{first\ 3740}#)
#f))))))
- (#{andmap\ 1241}# #{first\ 1238}#))
- (letrec ((#{andmap\ 1245}#
- (lambda (#{first\ 1246}# #{rest\ 1247}#)
- (let ((#{x\ 1248}# (car #{first\ 1246}#))
- (#{xr\ 1249}# (map car #{rest\ 1247}#))
- (#{first\ 1250}# (cdr #{first\ 1246}#))
- (#{rest\ 1251}#
- (map cdr #{rest\ 1247}#)))
- (if (null? #{first\ 1250}#)
- (apply #{f\ 1239}#
- (cons #{x\ 1248}# #{xr\ 1249}#))
- (if (apply #{f\ 1239}#
- (cons #{x\ 1248}# #{xr\ 1249}#))
- (#{andmap\ 1245}#
- #{first\ 1250}#
- #{rest\ 1251}#)
+ (#{andmap\ 3737}# #{first\ 3734}#))
+ (letrec ((#{andmap\ 3741}#
+ (lambda (#{first\ 3742}# #{rest\ 3743}#)
+ (let ((#{x\ 3744}# (car #{first\ 3742}#))
+ (#{xr\ 3745}# (map car #{rest\ 3743}#))
+ (#{first\ 3746}# (cdr #{first\ 3742}#))
+ (#{rest\ 3747}#
+ (map cdr #{rest\ 3743}#)))
+ (if (null? #{first\ 3746}#)
+ (apply #{f\ 3733}#
+ (cons #{x\ 3744}# #{xr\ 3745}#))
+ (if (apply #{f\ 3733}#
+ (cons #{x\ 3744}# #{xr\ 3745}#))
+ (#{andmap\ 3741}#
+ #{first\ 3746}#
+ #{rest\ 3747}#)
#f))))))
- (#{andmap\ 1245}# #{first\ 1238}# #{rest\ 1237}#))))))))
- (letrec ((#{lambda-var-list\ 1345}#
- (lambda (#{vars\ 1469}#)
- (letrec ((#{lvl\ 1470}#
- (lambda (#{vars\ 1471}# #{ls\ 1472}# #{w\ 1473}#)
- (if (pair? #{vars\ 1471}#)
- (#{lvl\ 1470}#
- (cdr #{vars\ 1471}#)
- (cons (#{wrap\ 1325}#
- (car #{vars\ 1471}#)
- #{w\ 1473}#
+ (#{andmap\ 3741}# #{first\ 3734}# #{rest\ 3735}#))))))))
+ (letrec ((#{lambda-var-list\ 3846}#
+ (lambda (#{vars\ 3970}#)
+ (letrec ((#{lvl\ 3971}#
+ (lambda (#{vars\ 3972}# #{ls\ 3973}# #{w\ 3974}#)
+ (if (pair? #{vars\ 3972}#)
+ (#{lvl\ 3971}#
+ (cdr #{vars\ 3972}#)
+ (cons (#{wrap\ 3823}#
+ (car #{vars\ 3972}#)
+ #{w\ 3974}#
#f)
- #{ls\ 1472}#)
- #{w\ 1473}#)
- (if (#{id?\ 1297}# #{vars\ 1471}#)
- (cons (#{wrap\ 1325}#
- #{vars\ 1471}#
- #{w\ 1473}#
+ #{ls\ 3973}#)
+ #{w\ 3974}#)
+ (if (#{id?\ 3795}# #{vars\ 3972}#)
+ (cons (#{wrap\ 3823}#
+ #{vars\ 3972}#
+ #{w\ 3974}#
#f)
- #{ls\ 1472}#)
- (if (null? #{vars\ 1471}#)
- #{ls\ 1472}#
- (if (#{syntax-object?\ 1281}# #{vars\ 1471}#)
- (#{lvl\ 1470}#
- (#{syntax-object-expression\ 1282}#
- #{vars\ 1471}#)
- #{ls\ 1472}#
- (#{join-wraps\ 1316}#
- #{w\ 1473}#
- (#{syntax-object-wrap\ 1283}#
- #{vars\ 1471}#)))
- (cons #{vars\ 1471}# #{ls\ 1472}#))))))))
- (#{lvl\ 1470}#
- #{vars\ 1469}#
+ #{ls\ 3973}#)
+ (if (null? #{vars\ 3972}#)
+ #{ls\ 3973}#
+ (if (#{syntax-object?\ 3779}# #{vars\ 3972}#)
+ (#{lvl\ 3971}#
+ (#{syntax-object-expression\ 3780}#
+ #{vars\ 3972}#)
+ #{ls\ 3973}#
+ (#{join-wraps\ 3814}#
+ #{w\ 3974}#
+ (#{syntax-object-wrap\ 3781}#
+ #{vars\ 3972}#)))
+ (cons #{vars\ 3972}# #{ls\ 3973}#))))))))
+ (#{lvl\ 3971}#
+ #{vars\ 3970}#
'()
'(())))))
- (#{gen-var\ 1344}#
- (lambda (#{id\ 1474}#)
- (let ((#{id\ 1475}#
- (if (#{syntax-object?\ 1281}# #{id\ 1474}#)
- (#{syntax-object-expression\ 1282}# #{id\ 1474}#)
- #{id\ 1474}#)))
+ (#{gen-var\ 3845}#
+ (lambda (#{id\ 3975}#)
+ (let ((#{id\ 3976}#
+ (if (#{syntax-object?\ 3779}# #{id\ 3975}#)
+ (#{syntax-object-expression\ 3780}# #{id\ 3975}#)
+ #{id\ 3975}#)))
(gensym
- (string-append (symbol->string #{id\ 1475}#) " ")))))
- (#{strip\ 1343}#
- (lambda (#{x\ 1476}# #{w\ 1477}#)
+ (string-append (symbol->string #{id\ 3976}#) " ")))))
+ (#{strip\ 3844}#
+ (lambda (#{x\ 3977}# #{w\ 3978}#)
(if (memq 'top
- (#{wrap-marks\ 1300}# #{w\ 1477}#))
- #{x\ 1476}#
- (letrec ((#{f\ 1478}#
- (lambda (#{x\ 1479}#)
- (if (#{syntax-object?\ 1281}# #{x\ 1479}#)
- (#{strip\ 1343}#
- (#{syntax-object-expression\ 1282}#
- #{x\ 1479}#)
- (#{syntax-object-wrap\ 1283}# #{x\ 1479}#))
- (if (pair? #{x\ 1479}#)
- (let ((#{a\ 1480}#
- (#{f\ 1478}# (car #{x\ 1479}#)))
- (#{d\ 1481}#
- (#{f\ 1478}# (cdr #{x\ 1479}#))))
- (if (if (eq? #{a\ 1480}# (car #{x\ 1479}#))
- (eq? #{d\ 1481}# (cdr #{x\ 1479}#))
+ (#{wrap-marks\ 3798}# #{w\ 3978}#))
+ #{x\ 3977}#
+ (letrec ((#{f\ 3979}#
+ (lambda (#{x\ 3980}#)
+ (if (#{syntax-object?\ 3779}# #{x\ 3980}#)
+ (#{strip\ 3844}#
+ (#{syntax-object-expression\ 3780}#
+ #{x\ 3980}#)
+ (#{syntax-object-wrap\ 3781}# #{x\ 3980}#))
+ (if (pair? #{x\ 3980}#)
+ (let ((#{a\ 3981}#
+ (#{f\ 3979}# (car #{x\ 3980}#)))
+ (#{d\ 3982}#
+ (#{f\ 3979}# (cdr #{x\ 3980}#))))
+ (if (if (eq? #{a\ 3981}# (car #{x\ 3980}#))
+ (eq? #{d\ 3982}# (cdr #{x\ 3980}#))
#f)
- #{x\ 1479}#
- (cons #{a\ 1480}# #{d\ 1481}#)))
- (if (vector? #{x\ 1479}#)
- (let ((#{old\ 1482}#
- (vector->list #{x\ 1479}#)))
- (let ((#{new\ 1483}#
- (map #{f\ 1478}# #{old\ 1482}#)))
- (if (#{and-map*\ 1199}#
+ #{x\ 3980}#
+ (cons #{a\ 3981}# #{d\ 3982}#)))
+ (if (vector? #{x\ 3980}#)
+ (let ((#{old\ 3983}#
+ (vector->list #{x\ 3980}#)))
+ (let ((#{new\ 3984}#
+ (map #{f\ 3979}# #{old\ 3983}#)))
+ (if (#{and-map*\ 3695}#
eq?
- #{old\ 1482}#
- #{new\ 1483}#)
- #{x\ 1479}#
- (list->vector #{new\ 1483}#))))
- #{x\ 1479}#))))))
- (#{f\ 1478}# #{x\ 1476}#)))))
- (#{ellipsis?\ 1342}#
- (lambda (#{x\ 1484}#)
- (if (#{nonsymbol-id?\ 1296}# #{x\ 1484}#)
- (#{free-id=?\ 1320}#
- #{x\ 1484}#
+ #{old\ 3983}#
+ #{new\ 3984}#)
+ #{x\ 3980}#
+ (list->vector #{new\ 3984}#))))
+ #{x\ 3980}#))))))
+ (#{f\ 3979}# #{x\ 3977}#)))))
+ (#{chi-lambda-case\ 3843}#
+ (lambda (#{e\ 3985}#
+ #{r\ 3986}#
+ #{w\ 3987}#
+ #{s\ 3988}#
+ #{mod\ 3989}#
+ #{get-formals\ 3990}#
+ #{clauses\ 3991}#)
+ (letrec ((#{expand-body\ 3995}#
+ (lambda (#{req\ 3996}#
+ #{opt\ 3997}#
+ #{rest\ 3998}#
+ #{kw\ 3999}#
+ #{body\ 4000}#
+ #{vars\ 4001}#
+ #{r*\ 4002}#
+ #{w*\ 4003}#
+ #{inits\ 4004}#)
+ ((lambda (#{tmp\ 4005}#)
+ ((lambda (#{tmp\ 4006}#)
+ (if (if #{tmp\ 4006}#
+ (apply (lambda (#{docstring\ 4007}#
+ #{e1\ 4008}#
+ #{e2\ 4009}#)
+ (string?
+ (syntax->datum
+ #{docstring\ 4007}#)))
+ #{tmp\ 4006}#)
+ #f)
+ (apply (lambda (#{docstring\ 4010}#
+ #{e1\ 4011}#
+ #{e2\ 4012}#)
+ (values
+ (syntax->datum
+ #{docstring\ 4010}#)
+ #{req\ 3996}#
+ #{opt\ 3997}#
+ #{rest\ 3998}#
+ #{kw\ 3999}#
+ #{inits\ 4004}#
+ #{vars\ 4001}#
+ (#{chi-body\ 3835}#
+ (cons #{e1\ 4011}#
+ #{e2\ 4012}#)
+ (#{source-wrap\ 3824}#
+ #{e\ 3985}#
+ #{w\ 3987}#
+ #{s\ 3988}#
+ #{mod\ 3989}#)
+ #{r*\ 4002}#
+ #{w*\ 4003}#
+ #{mod\ 3989}#)))
+ #{tmp\ 4006}#)
+ ((lambda (#{tmp\ 4014}#)
+ (if #{tmp\ 4014}#
+ (apply (lambda (#{e1\ 4015}#
+ #{e2\ 4016}#)
+ (values
+ #f
+ #{req\ 3996}#
+ #{opt\ 3997}#
+ #{rest\ 3998}#
+ #{kw\ 3999}#
+ #{inits\ 4004}#
+ #{vars\ 4001}#
+ (#{chi-body\ 3835}#
+ (cons #{e1\ 4015}#
+ #{e2\ 4016}#)
+ (#{source-wrap\ 3824}#
+ #{e\ 3985}#
+ #{w\ 3987}#
+ #{s\ 3988}#
+ #{mod\ 3989}#)
+ #{r*\ 4002}#
+ #{w*\ 4003}#
+ #{mod\ 3989}#)))
+ #{tmp\ 4014}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 4005}#)))
+ ($sc-dispatch
+ #{tmp\ 4005}#
+ '(any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 4005}#
+ '(any any . each-any))))
+ #{body\ 4000}#)))
+ (#{expand-kw\ 3994}#
+ (lambda (#{req\ 4018}#
+ #{opt\ 4019}#
+ #{rest\ 4020}#
+ #{kw\ 4021}#
+ #{body\ 4022}#
+ #{vars\ 4023}#
+ #{r*\ 4024}#
+ #{w*\ 4025}#
+ #{aok\ 4026}#
+ #{out\ 4027}#
+ #{inits\ 4028}#)
+ (if (pair? #{kw\ 4021}#)
+ ((lambda (#{tmp\ 4029}#)
+ ((lambda (#{tmp\ 4030}#)
+ (if #{tmp\ 4030}#
+ (apply (lambda (#{k\ 4031}#
+ #{id\ 4032}#
+ #{i\ 4033}#)
+ (let ((#{v\ 4034}#
+ (#{gen-var\ 3845}#
+ #{id\ 4032}#)))
+ (let ((#{l\ 4035}#
+ (#{gen-labels\ 3801}#
+ (list #{v\ 4034}#))))
+ (let ((#{r**\ 4036}#
+ (#{extend-var-env\ 3790}#
+ #{l\ 4035}#
+ (list #{v\ 4034}#)
+ #{r*\ 4024}#)))
+ (let ((#{w**\ 4037}#
+ (#{make-binding-wrap\ 3812}#
+ (list #{id\ 4032}#)
+ #{l\ 4035}#
+ #{w*\ 4025}#)))
+ (#{expand-kw\ 3994}#
+ #{req\ 4018}#
+ #{opt\ 4019}#
+ #{rest\ 4020}#
+ (cdr #{kw\ 4021}#)
+ #{body\ 4022}#
+ (cons #{v\ 4034}#
+ #{vars\ 4023}#)
+ #{r**\ 4036}#
+ #{w**\ 4037}#
+ #{aok\ 4026}#
+ (cons (list (syntax->datum
+ #{k\ 4031}#)
+ (syntax->datum
+ #{id\ 4032}#)
+ #{v\ 4034}#)
+ #{out\ 4027}#)
+ (cons (#{chi\ 3831}#
+ #{i\ 4033}#
+ #{r*\ 4024}#
+ #{w*\ 4025}#
+ #{mod\ 3989}#)
+ #{inits\ 4028}#)))))))
+ #{tmp\ 4030}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 4029}#)))
+ ($sc-dispatch
+ #{tmp\ 4029}#
+ '(any any any))))
+ (car #{kw\ 4021}#))
+ (#{expand-body\ 3995}#
+ #{req\ 4018}#
+ #{opt\ 4019}#
+ #{rest\ 4020}#
+ (if (let ((#{t\ 4038}# #{aok\ 4026}#))
+ (if #{t\ 4038}#
+ #{t\ 4038}#
+ (pair? #{out\ 4027}#)))
+ (cons #{aok\ 4026}# (reverse #{out\ 4027}#))
+ #f)
+ #{body\ 4022}#
+ (reverse #{vars\ 4023}#)
+ #{r*\ 4024}#
+ #{w*\ 4025}#
+ (reverse #{inits\ 4028}#)))))
+ (#{expand-opt\ 3993}#
+ (lambda (#{req\ 4039}#
+ #{opt\ 4040}#
+ #{rest\ 4041}#
+ #{kw\ 4042}#
+ #{body\ 4043}#
+ #{vars\ 4044}#
+ #{r*\ 4045}#
+ #{w*\ 4046}#
+ #{out\ 4047}#
+ #{inits\ 4048}#)
+ (if (pair? #{opt\ 4040}#)
+ ((lambda (#{tmp\ 4049}#)
+ ((lambda (#{tmp\ 4050}#)
+ (if #{tmp\ 4050}#
+ (apply (lambda (#{id\ 4051}# #{i\ 4052}#)
+ (let ((#{v\ 4053}#
+ (#{gen-var\ 3845}#
+ #{id\ 4051}#)))
+ (let ((#{l\ 4054}#
+ (#{gen-labels\ 3801}#
+ (list #{v\ 4053}#))))
+ (let ((#{r**\ 4055}#
+ (#{extend-var-env\ 3790}#
+ #{l\ 4054}#
+ (list #{v\ 4053}#)
+ #{r*\ 4045}#)))
+ (let ((#{w**\ 4056}#
+ (#{make-binding-wrap\ 3812}#
+ (list #{id\ 4051}#)
+ #{l\ 4054}#
+ #{w*\ 4046}#)))
+ (#{expand-opt\ 3993}#
+ #{req\ 4039}#
+ (cdr #{opt\ 4040}#)
+ #{rest\ 4041}#
+ #{kw\ 4042}#
+ #{body\ 4043}#
+ (cons #{v\ 4053}#
+ #{vars\ 4044}#)
+ #{r**\ 4055}#
+ #{w**\ 4056}#
+ (cons (syntax->datum
+ #{id\ 4051}#)
+ #{out\ 4047}#)
+ (cons (#{chi\ 3831}#
+ #{i\ 4052}#
+ #{r*\ 4045}#
+ #{w*\ 4046}#
+ #{mod\ 3989}#)
+ #{inits\ 4048}#)))))))
+ #{tmp\ 4050}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 4049}#)))
+ ($sc-dispatch
+ #{tmp\ 4049}#
+ '(any any))))
+ (car #{opt\ 4040}#))
+ (if #{rest\ 4041}#
+ (let ((#{v\ 4057}#
+ (#{gen-var\ 3845}# #{rest\ 4041}#)))
+ (let ((#{l\ 4058}#
+ (#{gen-labels\ 3801}#
+ (list #{v\ 4057}#))))
+ (let ((#{r*\ 4059}#
+ (#{extend-var-env\ 3790}#
+ #{l\ 4058}#
+ (list #{v\ 4057}#)
+ #{r*\ 4045}#)))
+ (let ((#{w*\ 4060}#
+ (#{make-binding-wrap\ 3812}#
+ (list #{rest\ 4041}#)
+ #{l\ 4058}#
+ #{w*\ 4046}#)))
+ (#{expand-kw\ 3994}#
+ #{req\ 4039}#
+ (if (pair? #{out\ 4047}#)
+ (reverse #{out\ 4047}#)
+ #f)
+ (syntax->datum #{rest\ 4041}#)
+ (if (pair? #{kw\ 4042}#)
+ (cdr #{kw\ 4042}#)
+ #{kw\ 4042}#)
+ #{body\ 4043}#
+ (cons #{v\ 4057}# #{vars\ 4044}#)
+ #{r*\ 4059}#
+ #{w*\ 4060}#
+ (if (pair? #{kw\ 4042}#)
+ (car #{kw\ 4042}#)
+ #f)
+ '()
+ #{inits\ 4048}#)))))
+ (#{expand-kw\ 3994}#
+ #{req\ 4039}#
+ (if (pair? #{out\ 4047}#)
+ (reverse #{out\ 4047}#)
+ #f)
+ #f
+ (if (pair? #{kw\ 4042}#)
+ (cdr #{kw\ 4042}#)
+ #{kw\ 4042}#)
+ #{body\ 4043}#
+ #{vars\ 4044}#
+ #{r*\ 4045}#
+ #{w*\ 4046}#
+ (if (pair? #{kw\ 4042}#)
+ (car #{kw\ 4042}#)
+ #f)
+ '()
+ #{inits\ 4048}#)))))
+ (#{expand-req\ 3992}#
+ (lambda (#{req\ 4061}#
+ #{opt\ 4062}#
+ #{rest\ 4063}#
+ #{kw\ 4064}#
+ #{body\ 4065}#)
+ (let ((#{vars\ 4066}#
+ (map #{gen-var\ 3845}# #{req\ 4061}#))
+ (#{labels\ 4067}#
+ (#{gen-labels\ 3801}# #{req\ 4061}#)))
+ (let ((#{r*\ 4068}#
+ (#{extend-var-env\ 3790}#
+ #{labels\ 4067}#
+ #{vars\ 4066}#
+ #{r\ 3986}#))
+ (#{w*\ 4069}#
+ (#{make-binding-wrap\ 3812}#
+ #{req\ 4061}#
+ #{labels\ 4067}#
+ #{w\ 3987}#)))
+ (#{expand-opt\ 3993}#
+ (map syntax->datum #{req\ 4061}#)
+ #{opt\ 4062}#
+ #{rest\ 4063}#
+ #{kw\ 4064}#
+ #{body\ 4065}#
+ (reverse #{vars\ 4066}#)
+ #{r*\ 4068}#
+ #{w*\ 4069}#
+ '()
+ '()))))))
+ ((lambda (#{tmp\ 4070}#)
+ ((lambda (#{tmp\ 4071}#)
+ (if #{tmp\ 4071}#
+ (apply (lambda () (values #f #f)) #{tmp\ 4071}#)
+ ((lambda (#{tmp\ 4072}#)
+ (if #{tmp\ 4072}#
+ (apply (lambda (#{args\ 4073}#
+ #{e1\ 4074}#
+ #{e2\ 4075}#
+ #{args*\ 4076}#
+ #{e1*\ 4077}#
+ #{e2*\ 4078}#)
+ (call-with-values
+ (lambda ()
+ (#{get-formals\ 3990}#
+ #{args\ 4073}#))
+ (lambda (#{req\ 4079}#
+ #{opt\ 4080}#
+ #{rest\ 4081}#
+ #{kw\ 4082}#)
+ (call-with-values
+ (lambda ()
+ (#{expand-req\ 3992}#
+ #{req\ 4079}#
+ #{opt\ 4080}#
+ #{rest\ 4081}#
+ #{kw\ 4082}#
+ (cons #{e1\ 4074}#
+ #{e2\ 4075}#)))
+ (lambda (#{docstring\ 4084}#
+ #{req\ 4085}#
+ #{opt\ 4086}#
+ #{rest\ 4087}#
+ #{kw\ 4088}#
+ #{inits\ 4089}#
+ #{vars\ 4090}#
+ #{body\ 4091}#)
+ (call-with-values
+ (lambda ()
+ (#{chi-lambda-case\ 3843}#
+ #{e\ 3985}#
+ #{r\ 3986}#
+ #{w\ 3987}#
+ #{s\ 3988}#
+ #{mod\ 3989}#
+ #{get-formals\ 3990}#
+ (map (lambda (#{tmp\ 4094}#
+ #{tmp\ 4093}#
+ #{tmp\ 4092}#)
+ (cons #{tmp\ 4092}#
+ (cons #{tmp\ 4093}#
+ #{tmp\ 4094}#)))
+ #{e2*\ 4078}#
+ #{e1*\ 4077}#
+ #{args*\ 4076}#)))
+ (lambda (#{docstring*\ 4096}#
+ #{else*\ 4097}#)
+ (values
+ (let ((#{t\ 4098}#
+ #{docstring\ 4084}#))
+ (if #{t\ 4098}#
+ #{t\ 4098}#
+ #{docstring*\ 4096}#))
+ (#{build-lambda-case\ 3771}#
+ #{s\ 3988}#
+ #{req\ 4085}#
+ #{opt\ 4086}#
+ #{rest\ 4087}#
+ #{kw\ 4088}#
+ #{inits\ 4089}#
+ #{vars\ 4090}#
+ #{body\ 4091}#
+ #{else*\ 4097}#)))))))))
+ #{tmp\ 4072}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 4070}#)))
+ ($sc-dispatch
+ #{tmp\ 4070}#
+ '((any any . each-any)
+ .
+ #(each (any any . each-any)))))))
+ ($sc-dispatch #{tmp\ 4070}# (quote ()))))
+ #{clauses\ 3991}#))))
+ (#{lambda*-formals\ 3842}#
+ (lambda (#{orig-args\ 4099}#)
+ (letrec ((#{check\ 4104}#
+ (lambda (#{req\ 4105}#
+ #{opt\ 4106}#
+ #{rest\ 4107}#
+ #{kw\ 4108}#)
+ (if (#{distinct-bound-ids?\ 3821}#
+ (append
+ #{req\ 4105}#
+ (map car #{opt\ 4106}#)
+ (if #{rest\ 4107}#
+ (list #{rest\ 4107}#)
+ '())
+ (if (pair? #{kw\ 4108}#)
+ (map cadr (cdr #{kw\ 4108}#))
+ '())))
+ (values
+ #{req\ 4105}#
+ #{opt\ 4106}#
+ #{rest\ 4107}#
+ #{kw\ 4108}#)
+ (syntax-violation
+ 'lambda*
+ "duplicate identifier in argument list"
+ #{orig-args\ 4099}#))))
+ (#{rest\ 4103}#
+ (lambda (#{args\ 4109}#
+ #{req\ 4110}#
+ #{opt\ 4111}#
+ #{kw\ 4112}#)
+ ((lambda (#{tmp\ 4113}#)
+ ((lambda (#{tmp\ 4114}#)
+ (if (if #{tmp\ 4114}#
+ (apply (lambda (#{r\ 4115}#)
+ (#{id?\ 3795}# #{r\ 4115}#))
+ #{tmp\ 4114}#)
+ #f)
+ (apply (lambda (#{r\ 4116}#)
+ (#{check\ 4104}#
+ #{req\ 4110}#
+ #{opt\ 4111}#
+ #{r\ 4116}#
+ #{kw\ 4112}#))
+ #{tmp\ 4114}#)
+ ((lambda (#{else\ 4117}#)
+ (syntax-violation
+ 'lambda*
+ "invalid rest argument"
+ #{orig-args\ 4099}#
+ #{args\ 4109}#))
+ #{tmp\ 4113}#)))
+ (list #{tmp\ 4113}#)))
+ #{args\ 4109}#)))
+ (#{key\ 4102}#
+ (lambda (#{args\ 4118}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ #{rkey\ 4121}#)
+ ((lambda (#{tmp\ 4122}#)
+ ((lambda (#{tmp\ 4123}#)
+ (if #{tmp\ 4123}#
+ (apply (lambda ()
+ (#{check\ 4104}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ #f
+ (cons #f
+ (reverse
+ #{rkey\ 4121}#))))
+ #{tmp\ 4123}#)
+ ((lambda (#{tmp\ 4124}#)
+ (if (if #{tmp\ 4124}#
+ (apply (lambda (#{a\ 4125}#
+ #{b\ 4126}#)
+ (#{id?\ 3795}#
+ #{a\ 4125}#))
+ #{tmp\ 4124}#)
+ #f)
+ (apply (lambda (#{a\ 4127}#
+ #{b\ 4128}#)
+ ((lambda (#{tmp\ 4129}#)
+ ((lambda (#{k\ 4130}#)
+ (#{key\ 4102}#
+ #{b\ 4128}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ (cons (cons #{k\ 4130}#
+ (cons #{a\ 4127}#
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(k)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(a
+ b)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(args
+ req
+ opt
+ rkey)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (check rest
+ key
+ opt
+ req)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ #(orig-args)
+ #((top))
+ #("i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top)
+ (top))
+ ("i"
+ "i")))
+ (hygiene
+ guile)))))
+ #{rkey\ 4121}#)))
+ #{tmp\ 4129}#))
+ (symbol->keyword
+ (syntax->datum
+ #{a\ 4127}#))))
+ #{tmp\ 4124}#)
+ ((lambda (#{tmp\ 4131}#)
+ (if (if #{tmp\ 4131}#
+ (apply (lambda (#{a\ 4132}#
+ #{init\ 4133}#
+ #{b\ 4134}#)
+ (#{id?\ 3795}#
+ #{a\ 4132}#))
+ #{tmp\ 4131}#)
+ #f)
+ (apply (lambda (#{a\ 4135}#
+ #{init\ 4136}#
+ #{b\ 4137}#)
+ ((lambda (#{tmp\ 4138}#)
+ ((lambda (#{k\ 4139}#)
+ (#{key\ 4102}#
+ #{b\ 4137}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ (cons (list #{k\ 4139}#
+ #{a\ 4135}#
+ #{init\ 4136}#)
+ #{rkey\ 4121}#)))
+ #{tmp\ 4138}#))
+ (symbol->keyword
+ (syntax->datum
+ #{a\ 4135}#))))
+ #{tmp\ 4131}#)
+ ((lambda (#{tmp\ 4140}#)
+ (if (if #{tmp\ 4140}#
+ (apply (lambda (#{a\ 4141}#
+ #{init\ 4142}#
+ #{k\ 4143}#
+ #{b\ 4144}#)
+ (if (#{id?\ 3795}#
+ #{a\ 4141}#)
+ (keyword?
+ (syntax->datum
+ #{k\ 4143}#))
+ #f))
+ #{tmp\ 4140}#)
+ #f)
+ (apply (lambda (#{a\ 4145}#
+ #{init\ 4146}#
+ #{k\ 4147}#
+ #{b\ 4148}#)
+ (#{key\ 4102}#
+ #{b\ 4148}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ (cons (list #{k\ 4147}#
+ #{a\ 4145}#
+ #{init\ 4146}#)
+ #{rkey\ 4121}#)))
+ #{tmp\ 4140}#)
+ ((lambda (#{tmp\ 4149}#)
+ (if (if #{tmp\ 4149}#
+ (apply (lambda (#{aok\ 4150}#)
+ (eq? (syntax->datum
+ #{aok\ 4150}#)
+ #:allow-other-keys))
+ #{tmp\ 4149}#)
+ #f)
+ (apply (lambda (#{aok\ 4151}#)
+ (#{check\ 4104}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ #f
+ (cons #t
+ (reverse
+ #{rkey\ 4121}#))))
+ #{tmp\ 4149}#)
+ ((lambda (#{tmp\ 4152}#)
+ (if (if #{tmp\ 4152}#
+ (apply (lambda (#{aok\ 4153}#
+ #{a\ 4154}#
+ #{b\ 4155}#)
+ (if (eq? (syntax->datum
+ #{aok\ 4153}#)
+ #:allow-other-keys)
+ (eq? (syntax->datum
+ #{a\ 4154}#)
+ #:rest)
+ #f))
+ #{tmp\ 4152}#)
+ #f)
+ (apply (lambda (#{aok\ 4156}#
+ #{a\ 4157}#
+ #{b\ 4158}#)
+ (#{rest\ 4103}#
+ #{b\ 4158}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ (cons #t
+ (reverse
+ #{rkey\ 4121}#))))
+ #{tmp\ 4152}#)
+ ((lambda (#{tmp\ 4159}#)
+ (if (if #{tmp\ 4159}#
+ (apply (lambda (#{aok\ 4160}#
+ #{r\ 4161}#)
+ (if (eq? (syntax->datum
+ #{aok\ 4160}#)
+ #:allow-other-keys)
+ (#{id?\ 3795}#
+ #{r\ 4161}#)
+ #f))
+ #{tmp\ 4159}#)
+ #f)
+ (apply (lambda (#{aok\ 4162}#
+ #{r\ 4163}#)
+ (#{rest\ 4103}#
+ #{r\ 4163}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ (cons #t
+ (reverse
+ #{rkey\ 4121}#))))
+ #{tmp\ 4159}#)
+ ((lambda (#{tmp\ 4164}#)
+ (if (if #{tmp\ 4164}#
+ (apply (lambda (#{a\ 4165}#
+ #{b\ 4166}#)
+ (eq? (syntax->datum
+ #{a\ 4165}#)
+ #:rest))
+ #{tmp\ 4164}#)
+ #f)
+ (apply (lambda (#{a\ 4167}#
+ #{b\ 4168}#)
+ (#{rest\ 4103}#
+ #{b\ 4168}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ (cons #f
+ (reverse
+ #{rkey\ 4121}#))))
+ #{tmp\ 4164}#)
+ ((lambda (#{tmp\ 4169}#)
+ (if (if #{tmp\ 4169}#
+ (apply (lambda (#{r\ 4170}#)
+ (#{id?\ 3795}#
+ #{r\ 4170}#))
+ #{tmp\ 4169}#)
+ #f)
+ (apply (lambda (#{r\ 4171}#)
+ (#{rest\ 4103}#
+ #{r\ 4171}#
+ #{req\ 4119}#
+ #{opt\ 4120}#
+ (cons #f
+ (reverse
+ #{rkey\ 4121}#))))
+ #{tmp\ 4169}#)
+ ((lambda (#{else\ 4172}#)
+ (syntax-violation
+ 'lambda*
+ "invalid keyword argument list"
+ #{orig-args\ 4099}#
+ #{args\ 4118}#))
+ #{tmp\ 4122}#)))
+ (list #{tmp\ 4122}#))))
+ ($sc-dispatch
+ #{tmp\ 4122}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 4122}#
+ '(any .
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 4122}#
+ '(any any any)))))
+ ($sc-dispatch
+ #{tmp\ 4122}#
+ '(any)))))
+ ($sc-dispatch
+ #{tmp\ 4122}#
+ '((any any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 4122}#
+ '((any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 4122}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 4122}# (quote ()))))
+ #{args\ 4118}#)))
+ (#{opt\ 4101}#
+ (lambda (#{args\ 4173}# #{req\ 4174}# #{ropt\ 4175}#)
+ ((lambda (#{tmp\ 4176}#)
+ ((lambda (#{tmp\ 4177}#)
+ (if #{tmp\ 4177}#
+ (apply (lambda ()
+ (#{check\ 4104}#
+ #{req\ 4174}#
+ (reverse #{ropt\ 4175}#)
+ #f
+ '()))
+ #{tmp\ 4177}#)
+ ((lambda (#{tmp\ 4178}#)
+ (if (if #{tmp\ 4178}#
+ (apply (lambda (#{a\ 4179}#
+ #{b\ 4180}#)
+ (#{id?\ 3795}#
+ #{a\ 4179}#))
+ #{tmp\ 4178}#)
+ #f)
+ (apply (lambda (#{a\ 4181}#
+ #{b\ 4182}#)
+ (#{opt\ 4101}#
+ #{b\ 4182}#
+ #{req\ 4174}#
+ (cons (cons #{a\ 4181}#
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(a b)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(args
+ req
+ ropt)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ (check rest
+ key
+ opt
+ req)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ #(orig-args)
+ #((top))
+ #("i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top)
+ (top))
+ ("i"
+ "i")))
+ (hygiene
+ guile))))
+ #{ropt\ 4175}#)))
+ #{tmp\ 4178}#)
+ ((lambda (#{tmp\ 4183}#)
+ (if (if #{tmp\ 4183}#
+ (apply (lambda (#{a\ 4184}#
+ #{init\ 4185}#
+ #{b\ 4186}#)
+ (#{id?\ 3795}#
+ #{a\ 4184}#))
+ #{tmp\ 4183}#)
+ #f)
+ (apply (lambda (#{a\ 4187}#
+ #{init\ 4188}#
+ #{b\ 4189}#)
+ (#{opt\ 4101}#
+ #{b\ 4189}#
+ #{req\ 4174}#
+ (cons (list #{a\ 4187}#
+ #{init\ 4188}#)
+ #{ropt\ 4175}#)))
+ #{tmp\ 4183}#)
+ ((lambda (#{tmp\ 4190}#)
+ (if (if #{tmp\ 4190}#
+ (apply (lambda (#{a\ 4191}#
+ #{b\ 4192}#)
+ (eq? (syntax->datum
+ #{a\ 4191}#)
+ #:key))
+ #{tmp\ 4190}#)
+ #f)
+ (apply (lambda (#{a\ 4193}#
+ #{b\ 4194}#)
+ (#{key\ 4102}#
+ #{b\ 4194}#
+ #{req\ 4174}#
+ (reverse
+ #{ropt\ 4175}#)
+ '()))
+ #{tmp\ 4190}#)
+ ((lambda (#{tmp\ 4195}#)
+ (if (if #{tmp\ 4195}#
+ (apply (lambda (#{a\ 4196}#
+ #{b\ 4197}#)
+ (eq? (syntax->datum
+ #{a\ 4196}#)
+ #:rest))
+ #{tmp\ 4195}#)
+ #f)
+ (apply (lambda (#{a\ 4198}#
+ #{b\ 4199}#)
+ (#{rest\ 4103}#
+ #{b\ 4199}#
+ #{req\ 4174}#
+ (reverse
+ #{ropt\ 4175}#)
+ '()))
+ #{tmp\ 4195}#)
+ ((lambda (#{tmp\ 4200}#)
+ (if (if #{tmp\ 4200}#
+ (apply (lambda (#{r\ 4201}#)
+ (#{id?\ 3795}#
+ #{r\ 4201}#))
+ #{tmp\ 4200}#)
+ #f)
+ (apply (lambda (#{r\ 4202}#)
+ (#{rest\ 4103}#
+ #{r\ 4202}#
+ #{req\ 4174}#
+ (reverse
+ #{ropt\ 4175}#)
+ '()))
+ #{tmp\ 4200}#)
+ ((lambda (#{else\ 4203}#)
+ (syntax-violation
+ 'lambda*
+ "invalid optional argument list"
+ #{orig-args\ 4099}#
+ #{args\ 4173}#))
+ #{tmp\ 4176}#)))
+ (list #{tmp\ 4176}#))))
+ ($sc-dispatch
+ #{tmp\ 4176}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 4176}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 4176}#
+ '((any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 4176}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 4176}# (quote ()))))
+ #{args\ 4173}#)))
+ (#{req\ 4100}#
+ (lambda (#{args\ 4204}# #{rreq\ 4205}#)
+ ((lambda (#{tmp\ 4206}#)
+ ((lambda (#{tmp\ 4207}#)
+ (if #{tmp\ 4207}#
+ (apply (lambda ()
+ (#{check\ 4104}#
+ (reverse #{rreq\ 4205}#)
+ '()
+ #f
+ '()))
+ #{tmp\ 4207}#)
+ ((lambda (#{tmp\ 4208}#)
+ (if (if #{tmp\ 4208}#
+ (apply (lambda (#{a\ 4209}#
+ #{b\ 4210}#)
+ (#{id?\ 3795}#
+ #{a\ 4209}#))
+ #{tmp\ 4208}#)
+ #f)
+ (apply (lambda (#{a\ 4211}#
+ #{b\ 4212}#)
+ (#{req\ 4100}#
+ #{b\ 4212}#
+ (cons #{a\ 4211}#
+ #{rreq\ 4205}#)))
+ #{tmp\ 4208}#)
+ ((lambda (#{tmp\ 4213}#)
+ (if (if #{tmp\ 4213}#
+ (apply (lambda (#{a\ 4214}#
+ #{b\ 4215}#)
+ (eq? (syntax->datum
+ #{a\ 4214}#)
+ #:optional))
+ #{tmp\ 4213}#)
+ #f)
+ (apply (lambda (#{a\ 4216}#
+ #{b\ 4217}#)
+ (#{opt\ 4101}#
+ #{b\ 4217}#
+ (reverse
+ #{rreq\ 4205}#)
+ '()))
+ #{tmp\ 4213}#)
+ ((lambda (#{tmp\ 4218}#)
+ (if (if #{tmp\ 4218}#
+ (apply (lambda (#{a\ 4219}#
+ #{b\ 4220}#)
+ (eq? (syntax->datum
+ #{a\ 4219}#)
+ #:key))
+ #{tmp\ 4218}#)
+ #f)
+ (apply (lambda (#{a\ 4221}#
+ #{b\ 4222}#)
+ (#{key\ 4102}#
+ #{b\ 4222}#
+ (reverse
+ #{rreq\ 4205}#)
+ '()
+ '()))
+ #{tmp\ 4218}#)
+ ((lambda (#{tmp\ 4223}#)
+ (if (if #{tmp\ 4223}#
+ (apply (lambda (#{a\ 4224}#
+ #{b\ 4225}#)
+ (eq? (syntax->datum
+ #{a\ 4224}#)
+ #:rest))
+ #{tmp\ 4223}#)
+ #f)
+ (apply (lambda (#{a\ 4226}#
+ #{b\ 4227}#)
+ (#{rest\ 4103}#
+ #{b\ 4227}#
+ (reverse
+ #{rreq\ 4205}#)
+ '()
+ '()))
+ #{tmp\ 4223}#)
+ ((lambda (#{tmp\ 4228}#)
+ (if (if #{tmp\ 4228}#
+ (apply (lambda (#{r\ 4229}#)
+ (#{id?\ 3795}#
+ #{r\ 4229}#))
+ #{tmp\ 4228}#)
+ #f)
+ (apply (lambda (#{r\ 4230}#)
+ (#{rest\ 4103}#
+ #{r\ 4230}#
+ (reverse
+ #{rreq\ 4205}#)
+ '()
+ '()))
+ #{tmp\ 4228}#)
+ ((lambda (#{else\ 4231}#)
+ (syntax-violation
+ 'lambda*
+ "invalid argument list"
+ #{orig-args\ 4099}#
+ #{args\ 4204}#))
+ #{tmp\ 4206}#)))
+ (list #{tmp\ 4206}#))))
+ ($sc-dispatch
+ #{tmp\ 4206}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 4206}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 4206}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 4206}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 4206}# (quote ()))))
+ #{args\ 4204}#))))
+ (#{req\ 4100}# #{orig-args\ 4099}# (quote ())))))
+ (#{chi-simple-lambda\ 3841}#
+ (lambda (#{e\ 4232}#
+ #{r\ 4233}#
+ #{w\ 4234}#
+ #{s\ 4235}#
+ #{mod\ 4236}#
+ #{req\ 4237}#
+ #{rest\ 4238}#
+ #{docstring\ 4239}#
+ #{body\ 4240}#)
+ (let ((#{ids\ 4241}#
+ (if #{rest\ 4238}#
+ (append #{req\ 4237}# (list #{rest\ 4238}#))
+ #{req\ 4237}#)))
+ (let ((#{vars\ 4242}#
+ (map #{gen-var\ 3845}# #{ids\ 4241}#)))
+ (let ((#{labels\ 4243}#
+ (#{gen-labels\ 3801}# #{ids\ 4241}#)))
+ (#{build-simple-lambda\ 3769}#
+ #{s\ 4235}#
+ (map syntax->datum #{req\ 4237}#)
+ (if #{rest\ 4238}#
+ (syntax->datum #{rest\ 4238}#)
+ #f)
+ #{vars\ 4242}#
+ #{docstring\ 4239}#
+ (#{chi-body\ 3835}#
+ #{body\ 4240}#
+ (#{source-wrap\ 3824}#
+ #{e\ 4232}#
+ #{w\ 4234}#
+ #{s\ 4235}#
+ #{mod\ 4236}#)
+ (#{extend-var-env\ 3790}#
+ #{labels\ 4243}#
+ #{vars\ 4242}#
+ #{r\ 4233}#)
+ (#{make-binding-wrap\ 3812}#
+ #{ids\ 4241}#
+ #{labels\ 4243}#
+ #{w\ 4234}#)
+ #{mod\ 4236}#)))))))
+ (#{lambda-formals\ 3840}#
+ (lambda (#{orig-args\ 4244}#)
+ (letrec ((#{check\ 4246}#
+ (lambda (#{req\ 4247}# #{rest\ 4248}#)
+ (if (#{distinct-bound-ids?\ 3821}#
+ (if #{rest\ 4248}#
+ (cons #{rest\ 4248}# #{req\ 4247}#)
+ #{req\ 4247}#))
+ (values #{req\ 4247}# #f #{rest\ 4248}# #f)
+ (syntax-violation
+ 'lambda
+ "duplicate identifier in argument list"
+ #{orig-args\ 4244}#))))
+ (#{req\ 4245}#
+ (lambda (#{args\ 4249}# #{rreq\ 4250}#)
+ ((lambda (#{tmp\ 4251}#)
+ ((lambda (#{tmp\ 4252}#)
+ (if #{tmp\ 4252}#
+ (apply (lambda ()
+ (#{check\ 4246}#
+ (reverse #{rreq\ 4250}#)
+ #f))
+ #{tmp\ 4252}#)
+ ((lambda (#{tmp\ 4253}#)
+ (if (if #{tmp\ 4253}#
+ (apply (lambda (#{a\ 4254}#
+ #{b\ 4255}#)
+ (#{id?\ 3795}#
+ #{a\ 4254}#))
+ #{tmp\ 4253}#)
+ #f)
+ (apply (lambda (#{a\ 4256}#
+ #{b\ 4257}#)
+ (#{req\ 4245}#
+ #{b\ 4257}#
+ (cons #{a\ 4256}#
+ #{rreq\ 4250}#)))
+ #{tmp\ 4253}#)
+ ((lambda (#{tmp\ 4258}#)
+ (if (if #{tmp\ 4258}#
+ (apply (lambda (#{r\ 4259}#)
+ (#{id?\ 3795}#
+ #{r\ 4259}#))
+ #{tmp\ 4258}#)
+ #f)
+ (apply (lambda (#{r\ 4260}#)
+ (#{check\ 4246}#
+ (reverse
+ #{rreq\ 4250}#)
+ #{r\ 4260}#))
+ #{tmp\ 4258}#)
+ ((lambda (#{else\ 4261}#)
+ (syntax-violation
+ 'lambda
+ "invalid argument list"
+ #{orig-args\ 4244}#
+ #{args\ 4249}#))
+ #{tmp\ 4251}#)))
+ (list #{tmp\ 4251}#))))
+ ($sc-dispatch
+ #{tmp\ 4251}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 4251}# (quote ()))))
+ #{args\ 4249}#))))
+ (#{req\ 4245}# #{orig-args\ 4244}# (quote ())))))
+ (#{ellipsis?\ 3839}#
+ (lambda (#{x\ 4262}#)
+ (if (#{nonsymbol-id?\ 3794}# #{x\ 4262}#)
+ (#{free-id=?\ 3818}#
+ #{x\ 4262}#
'#(syntax-object
...
((top)
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
("i" "i")))
(hygiene guile)))
#f)))
- (#{chi-void\ 1341}#
- (lambda () (#{build-void\ 1263}# #f)))
- (#{eval-local-transformer\ 1340}#
- (lambda (#{expanded\ 1485}# #{mod\ 1486}#)
- (let ((#{p\ 1487}#
- (#{local-eval-hook\ 1259}#
- #{expanded\ 1485}#
- #{mod\ 1486}#)))
- (if (procedure? #{p\ 1487}#)
- #{p\ 1487}#
+ (#{chi-void\ 3838}#
+ (lambda () (#{build-void\ 3759}# #f)))
+ (#{eval-local-transformer\ 3837}#
+ (lambda (#{expanded\ 4263}# #{mod\ 4264}#)
+ (let ((#{p\ 4265}#
+ (#{local-eval-hook\ 3755}#
+ #{expanded\ 4263}#
+ #{mod\ 4264}#)))
+ (if (procedure? #{p\ 4265}#)
+ (cons #{p\ 4265}# (module-name (current-module)))
(syntax-violation
#f
"nonprocedure transformer"
- #{p\ 1487}#)))))
- (#{chi-local-syntax\ 1339}#
- (lambda (#{rec?\ 1488}#
- #{e\ 1489}#
- #{r\ 1490}#
- #{w\ 1491}#
- #{s\ 1492}#
- #{mod\ 1493}#
- #{k\ 1494}#)
- ((lambda (#{tmp\ 1495}#)
- ((lambda (#{tmp\ 1496}#)
- (if #{tmp\ 1496}#
- (apply (lambda (#{_\ 1497}#
- #{id\ 1498}#
- #{val\ 1499}#
- #{e1\ 1500}#
- #{e2\ 1501}#)
- (let ((#{ids\ 1502}# #{id\ 1498}#))
- (if (not (#{valid-bound-ids?\ 1322}#
- #{ids\ 1502}#))
+ #{p\ 4265}#)))))
+ (#{chi-local-syntax\ 3836}#
+ (lambda (#{rec?\ 4266}#
+ #{e\ 4267}#
+ #{r\ 4268}#
+ #{w\ 4269}#
+ #{s\ 4270}#
+ #{mod\ 4271}#
+ #{k\ 4272}#)
+ ((lambda (#{tmp\ 4273}#)
+ ((lambda (#{tmp\ 4274}#)
+ (if #{tmp\ 4274}#
+ (apply (lambda (#{_\ 4275}#
+ #{id\ 4276}#
+ #{val\ 4277}#
+ #{e1\ 4278}#
+ #{e2\ 4279}#)
+ (let ((#{ids\ 4280}# #{id\ 4276}#))
+ (if (not (#{valid-bound-ids?\ 3820}#
+ #{ids\ 4280}#))
(syntax-violation
#f
"duplicate bound keyword"
- #{e\ 1489}#)
- (let ((#{labels\ 1504}#
- (#{gen-labels\ 1303}#
- #{ids\ 1502}#)))
- (let ((#{new-w\ 1505}#
- (#{make-binding-wrap\ 1314}#
- #{ids\ 1502}#
- #{labels\ 1504}#
- #{w\ 1491}#)))
- (#{k\ 1494}#
- (cons #{e1\ 1500}# #{e2\ 1501}#)
- (#{extend-env\ 1291}#
- #{labels\ 1504}#
- (let ((#{w\ 1507}#
- (if #{rec?\ 1488}#
- #{new-w\ 1505}#
- #{w\ 1491}#))
- (#{trans-r\ 1508}#
- (#{macros-only-env\ 1293}#
- #{r\ 1490}#)))
- (map (lambda (#{x\ 1509}#)
+ #{e\ 4267}#)
+ (let ((#{labels\ 4282}#
+ (#{gen-labels\ 3801}#
+ #{ids\ 4280}#)))
+ (let ((#{new-w\ 4283}#
+ (#{make-binding-wrap\ 3812}#
+ #{ids\ 4280}#
+ #{labels\ 4282}#
+ #{w\ 4269}#)))
+ (#{k\ 4272}#
+ (cons #{e1\ 4278}# #{e2\ 4279}#)
+ (#{extend-env\ 3789}#
+ #{labels\ 4282}#
+ (let ((#{w\ 4285}#
+ (if #{rec?\ 4266}#
+ #{new-w\ 4283}#
+ #{w\ 4269}#))
+ (#{trans-r\ 4286}#
+ (#{macros-only-env\ 3791}#
+ #{r\ 4268}#)))
+ (map (lambda (#{x\ 4287}#)
(cons 'macro
- (#{eval-local-transformer\ 1340}#
- (#{chi\ 1333}#
- #{x\ 1509}#
- #{trans-r\ 1508}#
- #{w\ 1507}#
- #{mod\ 1493}#)
- #{mod\ 1493}#)))
- #{val\ 1499}#))
- #{r\ 1490}#)
- #{new-w\ 1505}#
- #{s\ 1492}#
- #{mod\ 1493}#))))))
- #{tmp\ 1496}#)
- ((lambda (#{_\ 1511}#)
+ (#{eval-local-transformer\ 3837}#
+ (#{chi\ 3831}#
+ #{x\ 4287}#
+ #{trans-r\ 4286}#
+ #{w\ 4285}#
+ #{mod\ 4271}#)
+ #{mod\ 4271}#)))
+ #{val\ 4277}#))
+ #{r\ 4268}#)
+ #{new-w\ 4283}#
+ #{s\ 4270}#
+ #{mod\ 4271}#))))))
+ #{tmp\ 4274}#)
+ ((lambda (#{_\ 4289}#)
(syntax-violation
#f
"bad local syntax definition"
- (#{source-wrap\ 1326}#
- #{e\ 1489}#
- #{w\ 1491}#
- #{s\ 1492}#
- #{mod\ 1493}#)))
- #{tmp\ 1495}#)))
+ (#{source-wrap\ 3824}#
+ #{e\ 4267}#
+ #{w\ 4269}#
+ #{s\ 4270}#
+ #{mod\ 4271}#)))
+ #{tmp\ 4273}#)))
($sc-dispatch
- #{tmp\ 1495}#
+ #{tmp\ 4273}#
'(any #(each (any any)) any . each-any))))
- #{e\ 1489}#)))
- (#{chi-lambda-clause\ 1338}#
- (lambda (#{e\ 1512}#
- #{docstring\ 1513}#
- #{c\ 1514}#
- #{r\ 1515}#
- #{w\ 1516}#
- #{mod\ 1517}#
- #{k\ 1518}#)
- ((lambda (#{tmp\ 1519}#)
- ((lambda (#{tmp\ 1520}#)
- (if (if #{tmp\ 1520}#
- (apply (lambda (#{args\ 1521}#
- #{doc\ 1522}#
- #{e1\ 1523}#
- #{e2\ 1524}#)
- (if (string? (syntax->datum #{doc\ 1522}#))
- (not #{docstring\ 1513}#)
- #f))
- #{tmp\ 1520}#)
- #f)
- (apply (lambda (#{args\ 1525}#
- #{doc\ 1526}#
- #{e1\ 1527}#
- #{e2\ 1528}#)
- (#{chi-lambda-clause\ 1338}#
- #{e\ 1512}#
- #{doc\ 1526}#
- (cons #{args\ 1525}#
- (cons #{e1\ 1527}# #{e2\ 1528}#))
- #{r\ 1515}#
- #{w\ 1516}#
- #{mod\ 1517}#
- #{k\ 1518}#))
- #{tmp\ 1520}#)
- ((lambda (#{tmp\ 1530}#)
- (if #{tmp\ 1530}#
- (apply (lambda (#{id\ 1531}#
- #{e1\ 1532}#
- #{e2\ 1533}#)
- (let ((#{ids\ 1534}# #{id\ 1531}#))
- (if (not (#{valid-bound-ids?\ 1322}#
- #{ids\ 1534}#))
- (syntax-violation
- 'lambda
- "invalid parameter list"
- #{e\ 1512}#)
- (let ((#{labels\ 1536}#
- (#{gen-labels\ 1303}#
- #{ids\ 1534}#))
- (#{new-vars\ 1537}#
- (map #{gen-var\ 1344}#
- #{ids\ 1534}#)))
- (#{k\ 1518}#
- (map syntax->datum #{ids\ 1534}#)
- #{new-vars\ 1537}#
- (if #{docstring\ 1513}#
- (syntax->datum
- #{docstring\ 1513}#)
- #f)
- (#{chi-body\ 1337}#
- (cons #{e1\ 1532}# #{e2\ 1533}#)
- #{e\ 1512}#
- (#{extend-var-env\ 1292}#
- #{labels\ 1536}#
- #{new-vars\ 1537}#
- #{r\ 1515}#)
- (#{make-binding-wrap\ 1314}#
- #{ids\ 1534}#
- #{labels\ 1536}#
- #{w\ 1516}#)
- #{mod\ 1517}#))))))
- #{tmp\ 1530}#)
- ((lambda (#{tmp\ 1539}#)
- (if #{tmp\ 1539}#
- (apply (lambda (#{ids\ 1540}#
- #{e1\ 1541}#
- #{e2\ 1542}#)
- (let ((#{old-ids\ 1543}#
- (#{lambda-var-list\ 1345}#
- #{ids\ 1540}#)))
- (if (not (#{valid-bound-ids?\ 1322}#
- #{old-ids\ 1543}#))
- (syntax-violation
- 'lambda
- "invalid parameter list"
- #{e\ 1512}#)
- (let ((#{labels\ 1544}#
- (#{gen-labels\ 1303}#
- #{old-ids\ 1543}#))
- (#{new-vars\ 1545}#
- (map #{gen-var\ 1344}#
- #{old-ids\ 1543}#)))
- (#{k\ 1518}#
- (letrec ((#{f\ 1546}#
- (lambda (#{ls1\ 1547}#
- #{ls2\ 1548}#)
- (if (null? #{ls1\ 1547}#)
- (syntax->datum
- #{ls2\ 1548}#)
- (#{f\ 1546}#
- (cdr #{ls1\ 1547}#)
- (cons (syntax->datum
- (car #{ls1\ 1547}#))
- #{ls2\ 1548}#))))))
- (#{f\ 1546}#
- (cdr #{old-ids\ 1543}#)
- (car #{old-ids\ 1543}#)))
- (letrec ((#{f\ 1549}#
- (lambda (#{ls1\ 1550}#
- #{ls2\ 1551}#)
- (if (null? #{ls1\ 1550}#)
- #{ls2\ 1551}#
- (#{f\ 1549}#
- (cdr #{ls1\ 1550}#)
- (cons (car #{ls1\ 1550}#)
- #{ls2\ 1551}#))))))
- (#{f\ 1549}#
- (cdr #{new-vars\ 1545}#)
- (car #{new-vars\ 1545}#)))
- (if #{docstring\ 1513}#
- (syntax->datum
- #{docstring\ 1513}#)
- #f)
- (#{chi-body\ 1337}#
- (cons #{e1\ 1541}#
- #{e2\ 1542}#)
- #{e\ 1512}#
- (#{extend-var-env\ 1292}#
- #{labels\ 1544}#
- #{new-vars\ 1545}#
- #{r\ 1515}#)
- (#{make-binding-wrap\ 1314}#
- #{old-ids\ 1543}#
- #{labels\ 1544}#
- #{w\ 1516}#)
- #{mod\ 1517}#))))))
- #{tmp\ 1539}#)
- ((lambda (#{_\ 1553}#)
- (syntax-violation
- 'lambda
- "bad lambda"
- #{e\ 1512}#))
- #{tmp\ 1519}#)))
- ($sc-dispatch
- #{tmp\ 1519}#
- '(any any . each-any)))))
- ($sc-dispatch
- #{tmp\ 1519}#
- '(each-any any . each-any)))))
- ($sc-dispatch
- #{tmp\ 1519}#
- '(any any any . each-any))))
- #{c\ 1514}#)))
- (#{chi-body\ 1337}#
- (lambda (#{body\ 1554}#
- #{outer-form\ 1555}#
- #{r\ 1556}#
- #{w\ 1557}#
- #{mod\ 1558}#)
- (let ((#{r\ 1559}#
+ #{e\ 4267}#)))
+ (#{chi-body\ 3835}#
+ (lambda (#{body\ 4290}#
+ #{outer-form\ 4291}#
+ #{r\ 4292}#
+ #{w\ 4293}#
+ #{mod\ 4294}#)
+ (let ((#{r\ 4295}#
(cons '("placeholder" placeholder)
- #{r\ 1556}#)))
- (let ((#{ribcage\ 1560}#
- (#{make-ribcage\ 1304}#
+ #{r\ 4292}#)))
+ (let ((#{ribcage\ 4296}#
+ (#{make-ribcage\ 3802}#
'()
'()
'())))
- (let ((#{w\ 1561}#
- (#{make-wrap\ 1299}#
- (#{wrap-marks\ 1300}# #{w\ 1557}#)
- (cons #{ribcage\ 1560}#
- (#{wrap-subst\ 1301}# #{w\ 1557}#)))))
- (letrec ((#{parse\ 1562}#
- (lambda (#{body\ 1563}#
- #{ids\ 1564}#
- #{labels\ 1565}#
- #{var-ids\ 1566}#
- #{vars\ 1567}#
- #{vals\ 1568}#
- #{bindings\ 1569}#)
- (if (null? #{body\ 1563}#)
+ (let ((#{w\ 4297}#
+ (#{make-wrap\ 3797}#
+ (#{wrap-marks\ 3798}# #{w\ 4293}#)
+ (cons #{ribcage\ 4296}#
+ (#{wrap-subst\ 3799}# #{w\ 4293}#)))))
+ (letrec ((#{parse\ 4298}#
+ (lambda (#{body\ 4299}#
+ #{ids\ 4300}#
+ #{labels\ 4301}#
+ #{var-ids\ 4302}#
+ #{vars\ 4303}#
+ #{vals\ 4304}#
+ #{bindings\ 4305}#)
+ (if (null? #{body\ 4299}#)
(syntax-violation
#f
"no expressions in body"
- #{outer-form\ 1555}#)
- (let ((#{e\ 1571}# (cdar #{body\ 1563}#))
- (#{er\ 1572}# (caar #{body\ 1563}#)))
+ #{outer-form\ 4291}#)
+ (let ((#{e\ 4307}# (cdar #{body\ 4299}#))
+ (#{er\ 4308}# (caar #{body\ 4299}#)))
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{e\ 1571}#
- #{er\ 1572}#
+ (#{syntax-type\ 3829}#
+ #{e\ 4307}#
+ #{er\ 4308}#
'(())
- (#{source-annotation\ 1288}#
- #{er\ 1572}#)
- #{ribcage\ 1560}#
- #{mod\ 1558}#
+ (#{source-annotation\ 3786}#
+ #{er\ 4308}#)
+ #{ribcage\ 4296}#
+ #{mod\ 4294}#
#f))
- (lambda (#{type\ 1573}#
- #{value\ 1574}#
- #{e\ 1575}#
- #{w\ 1576}#
- #{s\ 1577}#
- #{mod\ 1578}#)
- (if (memv #{type\ 1573}#
+ (lambda (#{type\ 4309}#
+ #{value\ 4310}#
+ #{e\ 4311}#
+ #{w\ 4312}#
+ #{s\ 4313}#
+ #{mod\ 4314}#)
+ (if (memv #{type\ 4309}#
'(define-form))
- (let ((#{id\ 1579}#
- (#{wrap\ 1325}#
- #{value\ 1574}#
- #{w\ 1576}#
- #{mod\ 1578}#))
- (#{label\ 1580}#
- (#{gen-label\ 1302}#)))
- (let ((#{var\ 1581}#
- (#{gen-var\ 1344}#
- #{id\ 1579}#)))
+ (let ((#{id\ 4315}#
+ (#{wrap\ 3823}#
+ #{value\ 4310}#
+ #{w\ 4312}#
+ #{mod\ 4314}#))
+ (#{label\ 4316}#
+ (#{gen-label\ 3800}#)))
+ (let ((#{var\ 4317}#
+ (#{gen-var\ 3845}#
+ #{id\ 4315}#)))
(begin
- (#{extend-ribcage!\ 1313}#
- #{ribcage\ 1560}#
- #{id\ 1579}#
- #{label\ 1580}#)
- (#{parse\ 1562}#
- (cdr #{body\ 1563}#)
- (cons #{id\ 1579}#
- #{ids\ 1564}#)
- (cons #{label\ 1580}#
- #{labels\ 1565}#)
- (cons #{id\ 1579}#
- #{var-ids\ 1566}#)
- (cons #{var\ 1581}#
- #{vars\ 1567}#)
- (cons (cons #{er\ 1572}#
- (#{wrap\ 1325}#
- #{e\ 1575}#
- #{w\ 1576}#
- #{mod\ 1578}#))
- #{vals\ 1568}#)
+ (#{extend-ribcage!\ 3811}#
+ #{ribcage\ 4296}#
+ #{id\ 4315}#
+ #{label\ 4316}#)
+ (#{parse\ 4298}#
+ (cdr #{body\ 4299}#)
+ (cons #{id\ 4315}#
+ #{ids\ 4300}#)
+ (cons #{label\ 4316}#
+ #{labels\ 4301}#)
+ (cons #{id\ 4315}#
+ #{var-ids\ 4302}#)
+ (cons #{var\ 4317}#
+ #{vars\ 4303}#)
+ (cons (cons #{er\ 4308}#
+ (#{wrap\ 3823}#
+ #{e\ 4311}#
+ #{w\ 4312}#
+ #{mod\ 4314}#))
+ #{vals\ 4304}#)
(cons (cons 'lexical
- #{var\ 1581}#)
- #{bindings\ 1569}#)))))
- (if (memv #{type\ 1573}#
+ #{var\ 4317}#)
+ #{bindings\ 4305}#)))))
+ (if (memv #{type\ 4309}#
'(define-syntax-form))
- (let ((#{id\ 1582}#
- (#{wrap\ 1325}#
- #{value\ 1574}#
- #{w\ 1576}#
- #{mod\ 1578}#))
- (#{label\ 1583}#
- (#{gen-label\ 1302}#)))
+ (let ((#{id\ 4318}#
+ (#{wrap\ 3823}#
+ #{value\ 4310}#
+ #{w\ 4312}#
+ #{mod\ 4314}#))
+ (#{label\ 4319}#
+ (#{gen-label\ 3800}#)))
(begin
- (#{extend-ribcage!\ 1313}#
- #{ribcage\ 1560}#
- #{id\ 1582}#
- #{label\ 1583}#)
- (#{parse\ 1562}#
- (cdr #{body\ 1563}#)
- (cons #{id\ 1582}#
- #{ids\ 1564}#)
- (cons #{label\ 1583}#
- #{labels\ 1565}#)
- #{var-ids\ 1566}#
- #{vars\ 1567}#
- #{vals\ 1568}#
+ (#{extend-ribcage!\ 3811}#
+ #{ribcage\ 4296}#
+ #{id\ 4318}#
+ #{label\ 4319}#)
+ (#{parse\ 4298}#
+ (cdr #{body\ 4299}#)
+ (cons #{id\ 4318}#
+ #{ids\ 4300}#)
+ (cons #{label\ 4319}#
+ #{labels\ 4301}#)
+ #{var-ids\ 4302}#
+ #{vars\ 4303}#
+ #{vals\ 4304}#
(cons (cons 'macro
- (cons #{er\ 1572}#
- (#{wrap\ 1325}#
- #{e\ 1575}#
- #{w\ 1576}#
- #{mod\ 1578}#)))
- #{bindings\ 1569}#))))
- (if (memv #{type\ 1573}#
+ (cons #{er\ 4308}#
+ (#{wrap\ 3823}#
+ #{e\ 4311}#
+ #{w\ 4312}#
+ #{mod\ 4314}#)))
+ #{bindings\ 4305}#))))
+ (if (memv #{type\ 4309}#
'(begin-form))
- ((lambda (#{tmp\ 1584}#)
- ((lambda (#{tmp\ 1585}#)
- (if #{tmp\ 1585}#
- (apply (lambda (#{_\ 1586}#
- #{e1\ 1587}#)
- (#{parse\ 1562}#
- (letrec ((#{f\ 1588}#
- (lambda (#{forms\ 1589}#)
- (if (null? #{forms\ 1589}#)
- (cdr #{body\ 1563}#)
- (cons (cons #{er\ 1572}#
- (#{wrap\ 1325}#
- (car #{forms\ 1589}#)
- #{w\ 1576}#
- #{mod\ 1578}#))
- (#{f\ 1588}#
- (cdr #{forms\ 1589}#)))))))
- (#{f\ 1588}#
- #{e1\ 1587}#))
- #{ids\ 1564}#
- #{labels\ 1565}#
- #{var-ids\ 1566}#
- #{vars\ 1567}#
- #{vals\ 1568}#
- #{bindings\ 1569}#))
- #{tmp\ 1585}#)
+ ((lambda (#{tmp\ 4320}#)
+ ((lambda (#{tmp\ 4321}#)
+ (if #{tmp\ 4321}#
+ (apply (lambda (#{_\ 4322}#
+ #{e1\ 4323}#)
+ (#{parse\ 4298}#
+ (letrec ((#{f\ 4324}#
+ (lambda (#{forms\ 4325}#)
+ (if (null? #{forms\ 4325}#)
+ (cdr #{body\ 4299}#)
+ (cons (cons #{er\ 4308}#
+ (#{wrap\ 3823}#
+ (car #{forms\ 4325}#)
+ #{w\ 4312}#
+ #{mod\ 4314}#))
+ (#{f\ 4324}#
+ (cdr #{forms\ 4325}#)))))))
+ (#{f\ 4324}#
+ #{e1\ 4323}#))
+ #{ids\ 4300}#
+ #{labels\ 4301}#
+ #{var-ids\ 4302}#
+ #{vars\ 4303}#
+ #{vals\ 4304}#
+ #{bindings\ 4305}#))
+ #{tmp\ 4321}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1584}#)))
+ #{tmp\ 4320}#)))
($sc-dispatch
- #{tmp\ 1584}#
+ #{tmp\ 4320}#
'(any . each-any))))
- #{e\ 1575}#)
- (if (memv #{type\ 1573}#
+ #{e\ 4311}#)
+ (if (memv #{type\ 4309}#
'(local-syntax-form))
- (#{chi-local-syntax\ 1339}#
- #{value\ 1574}#
- #{e\ 1575}#
- #{er\ 1572}#
- #{w\ 1576}#
- #{s\ 1577}#
- #{mod\ 1578}#
- (lambda (#{forms\ 1591}#
- #{er\ 1592}#
- #{w\ 1593}#
- #{s\ 1594}#
- #{mod\ 1595}#)
- (#{parse\ 1562}#
- (letrec ((#{f\ 1596}#
- (lambda (#{forms\ 1597}#)
- (if (null? #{forms\ 1597}#)
- (cdr #{body\ 1563}#)
- (cons (cons #{er\ 1592}#
- (#{wrap\ 1325}#
- (car #{forms\ 1597}#)
- #{w\ 1593}#
- #{mod\ 1595}#))
- (#{f\ 1596}#
- (cdr #{forms\ 1597}#)))))))
- (#{f\ 1596}#
- #{forms\ 1591}#))
- #{ids\ 1564}#
- #{labels\ 1565}#
- #{var-ids\ 1566}#
- #{vars\ 1567}#
- #{vals\ 1568}#
- #{bindings\ 1569}#)))
- (if (null? #{ids\ 1564}#)
- (#{build-sequence\ 1276}#
+ (#{chi-local-syntax\ 3836}#
+ #{value\ 4310}#
+ #{e\ 4311}#
+ #{er\ 4308}#
+ #{w\ 4312}#
+ #{s\ 4313}#
+ #{mod\ 4314}#
+ (lambda (#{forms\ 4327}#
+ #{er\ 4328}#
+ #{w\ 4329}#
+ #{s\ 4330}#
+ #{mod\ 4331}#)
+ (#{parse\ 4298}#
+ (letrec ((#{f\ 4332}#
+ (lambda (#{forms\ 4333}#)
+ (if (null? #{forms\ 4333}#)
+ (cdr #{body\ 4299}#)
+ (cons (cons #{er\ 4328}#
+ (#{wrap\ 3823}#
+ (car #{forms\ 4333}#)
+ #{w\ 4329}#
+ #{mod\ 4331}#))
+ (#{f\ 4332}#
+ (cdr #{forms\ 4333}#)))))))
+ (#{f\ 4332}#
+ #{forms\ 4327}#))
+ #{ids\ 4300}#
+ #{labels\ 4301}#
+ #{var-ids\ 4302}#
+ #{vars\ 4303}#
+ #{vals\ 4304}#
+ #{bindings\ 4305}#)))
+ (if (null? #{ids\ 4300}#)
+ (#{build-sequence\ 3774}#
#f
- (map (lambda (#{x\ 1598}#)
- (#{chi\ 1333}#
- (cdr #{x\ 1598}#)
- (car #{x\ 1598}#)
+ (map (lambda (#{x\ 4334}#)
+ (#{chi\ 3831}#
+ (cdr #{x\ 4334}#)
+ (car #{x\ 4334}#)
'(())
- #{mod\ 1578}#))
- (cons (cons #{er\ 1572}#
- (#{source-wrap\ 1326}#
- #{e\ 1575}#
- #{w\ 1576}#
- #{s\ 1577}#
- #{mod\ 1578}#))
- (cdr #{body\ 1563}#))))
+ #{mod\ 4314}#))
+ (cons (cons #{er\ 4308}#
+ (#{source-wrap\ 3824}#
+ #{e\ 4311}#
+ #{w\ 4312}#
+ #{s\ 4313}#
+ #{mod\ 4314}#))
+ (cdr #{body\ 4299}#))))
(begin
- (if (not (#{valid-bound-ids?\ 1322}#
- #{ids\ 1564}#))
+ (if (not (#{valid-bound-ids?\ 3820}#
+ #{ids\ 4300}#))
(syntax-violation
#f
"invalid or duplicate identifier in definition"
- #{outer-form\ 1555}#))
- (letrec ((#{loop\ 1599}#
- (lambda (#{bs\ 1600}#
- #{er-cache\ 1601}#
- #{r-cache\ 1602}#)
- (if (not (null? #{bs\ 1600}#))
- (let ((#{b\ 1603}#
- (car #{bs\ 1600}#)))
- (if (eq? (car #{b\ 1603}#)
+ #{outer-form\ 4291}#))
+ (letrec ((#{loop\ 4335}#
+ (lambda (#{bs\ 4336}#
+ #{er-cache\ 4337}#
+ #{r-cache\ 4338}#)
+ (if (not (null? #{bs\ 4336}#))
+ (let ((#{b\ 4339}#
+ (car #{bs\ 4336}#)))
+ (if (eq? (car #{b\ 4339}#)
'macro)
- (let ((#{er\ 1604}#
- (cadr #{b\ 1603}#)))
- (let ((#{r-cache\ 1605}#
- (if (eq? #{er\ 1604}#
- #{er-cache\ 1601}#)
- #{r-cache\ 1602}#
- (#{macros-only-env\ 1293}#
- #{er\ 1604}#))))
+ (let ((#{er\ 4340}#
+ (cadr #{b\ 4339}#)))
+ (let ((#{r-cache\ 4341}#
+ (if (eq? #{er\ 4340}#
+ #{er-cache\ 4337}#)
+ #{r-cache\ 4338}#
+ (#{macros-only-env\ 3791}#
+ #{er\ 4340}#))))
(begin
(set-cdr!
- #{b\ 1603}#
- (#{eval-local-transformer\ 1340}#
- (#{chi\ 1333}#
- (cddr #{b\ 1603}#)
- #{r-cache\ 1605}#
+ #{b\ 4339}#
+ (#{eval-local-transformer\ 3837}#
+ (#{chi\ 3831}#
+ (cddr #{b\ 4339}#)
+ #{r-cache\ 4341}#
'(())
- #{mod\ 1578}#)
- #{mod\ 1578}#))
- (#{loop\ 1599}#
- (cdr #{bs\ 1600}#)
- #{er\ 1604}#
- #{r-cache\ 1605}#))))
- (#{loop\ 1599}#
- (cdr #{bs\ 1600}#)
- #{er-cache\ 1601}#
- #{r-cache\ 1602}#)))))))
- (#{loop\ 1599}#
- #{bindings\ 1569}#
+ #{mod\ 4314}#)
+ #{mod\ 4314}#))
+ (#{loop\ 4335}#
+ (cdr #{bs\ 4336}#)
+ #{er\ 4340}#
+ #{r-cache\ 4341}#))))
+ (#{loop\ 4335}#
+ (cdr #{bs\ 4336}#)
+ #{er-cache\ 4337}#
+ #{r-cache\ 4338}#)))))))
+ (#{loop\ 4335}#
+ #{bindings\ 4305}#
#f
#f))
(set-cdr!
- #{r\ 1559}#
- (#{extend-env\ 1291}#
- #{labels\ 1565}#
- #{bindings\ 1569}#
- (cdr #{r\ 1559}#)))
- (#{build-letrec\ 1279}#
+ #{r\ 4295}#
+ (#{extend-env\ 3789}#
+ #{labels\ 4301}#
+ #{bindings\ 4305}#
+ (cdr #{r\ 4295}#)))
+ (#{build-letrec\ 3777}#
#f
(map syntax->datum
- #{var-ids\ 1566}#)
- #{vars\ 1567}#
- (map (lambda (#{x\ 1606}#)
- (#{chi\ 1333}#
- (cdr #{x\ 1606}#)
- (car #{x\ 1606}#)
+ #{var-ids\ 4302}#)
+ #{vars\ 4303}#
+ (map (lambda (#{x\ 4342}#)
+ (#{chi\ 3831}#
+ (cdr #{x\ 4342}#)
+ (car #{x\ 4342}#)
'(())
- #{mod\ 1578}#))
- #{vals\ 1568}#)
- (#{build-sequence\ 1276}#
+ #{mod\ 4314}#))
+ #{vals\ 4304}#)
+ (#{build-sequence\ 3774}#
#f
- (map (lambda (#{x\ 1607}#)
- (#{chi\ 1333}#
- (cdr #{x\ 1607}#)
- (car #{x\ 1607}#)
+ (map (lambda (#{x\ 4343}#)
+ (#{chi\ 3831}#
+ (cdr #{x\ 4343}#)
+ (car #{x\ 4343}#)
'(())
- #{mod\ 1578}#))
- (cons (cons #{er\ 1572}#
- (#{source-wrap\ 1326}#
- #{e\ 1575}#
- #{w\ 1576}#
- #{s\ 1577}#
- #{mod\ 1578}#))
- (cdr #{body\ 1563}#))))))))))))))))))
- (#{parse\ 1562}#
- (map (lambda (#{x\ 1570}#)
- (cons #{r\ 1559}#
- (#{wrap\ 1325}#
- #{x\ 1570}#
- #{w\ 1561}#
- #{mod\ 1558}#)))
- #{body\ 1554}#)
+ #{mod\ 4314}#))
+ (cons (cons #{er\ 4308}#
+ (#{source-wrap\ 3824}#
+ #{e\ 4311}#
+ #{w\ 4312}#
+ #{s\ 4313}#
+ #{mod\ 4314}#))
+ (cdr #{body\ 4299}#))))))))))))))))))
+ (#{parse\ 4298}#
+ (map (lambda (#{x\ 4306}#)
+ (cons #{r\ 4295}#
+ (#{wrap\ 3823}#
+ #{x\ 4306}#
+ #{w\ 4297}#
+ #{mod\ 4294}#)))
+ #{body\ 4290}#)
'()
'()
'()
'()
'()
'())))))))
- (#{chi-macro\ 1336}#
- (lambda (#{p\ 1608}#
- #{e\ 1609}#
- #{r\ 1610}#
- #{w\ 1611}#
- #{rib\ 1612}#
- #{mod\ 1613}#)
- (letrec ((#{rebuild-macro-output\ 1614}#
- (lambda (#{x\ 1615}# #{m\ 1616}#)
- (if (pair? #{x\ 1615}#)
- (cons (#{rebuild-macro-output\ 1614}#
- (car #{x\ 1615}#)
- #{m\ 1616}#)
- (#{rebuild-macro-output\ 1614}#
- (cdr #{x\ 1615}#)
- #{m\ 1616}#))
- (if (#{syntax-object?\ 1281}# #{x\ 1615}#)
- (let ((#{w\ 1617}#
- (#{syntax-object-wrap\ 1283}#
- #{x\ 1615}#)))
- (let ((#{ms\ 1618}#
- (#{wrap-marks\ 1300}# #{w\ 1617}#))
- (#{s\ 1619}#
- (#{wrap-subst\ 1301}# #{w\ 1617}#)))
- (if (if (pair? #{ms\ 1618}#)
- (eq? (car #{ms\ 1618}#) #f)
+ (#{chi-macro\ 3834}#
+ (lambda (#{p\ 4344}#
+ #{e\ 4345}#
+ #{r\ 4346}#
+ #{w\ 4347}#
+ #{rib\ 4348}#
+ #{mod\ 4349}#)
+ (letrec ((#{rebuild-macro-output\ 4350}#
+ (lambda (#{x\ 4351}# #{m\ 4352}#)
+ (if (pair? #{x\ 4351}#)
+ (cons (#{rebuild-macro-output\ 4350}#
+ (car #{x\ 4351}#)
+ #{m\ 4352}#)
+ (#{rebuild-macro-output\ 4350}#
+ (cdr #{x\ 4351}#)
+ #{m\ 4352}#))
+ (if (#{syntax-object?\ 3779}# #{x\ 4351}#)
+ (let ((#{w\ 4353}#
+ (#{syntax-object-wrap\ 3781}#
+ #{x\ 4351}#)))
+ (let ((#{ms\ 4354}#
+ (#{wrap-marks\ 3798}# #{w\ 4353}#))
+ (#{s\ 4355}#
+ (#{wrap-subst\ 3799}# #{w\ 4353}#)))
+ (if (if (pair? #{ms\ 4354}#)
+ (eq? (car #{ms\ 4354}#) #f)
#f)
- (#{make-syntax-object\ 1280}#
- (#{syntax-object-expression\ 1282}#
- #{x\ 1615}#)
- (#{make-wrap\ 1299}#
- (cdr #{ms\ 1618}#)
- (if #{rib\ 1612}#
- (cons #{rib\ 1612}#
- (cdr #{s\ 1619}#))
- (cdr #{s\ 1619}#)))
- (#{syntax-object-module\ 1284}#
- #{x\ 1615}#))
- (#{make-syntax-object\ 1280}#
- (#{syntax-object-expression\ 1282}#
- #{x\ 1615}#)
- (#{make-wrap\ 1299}#
- (cons #{m\ 1616}# #{ms\ 1618}#)
- (if #{rib\ 1612}#
- (cons #{rib\ 1612}#
+ (#{make-syntax-object\ 3778}#
+ (#{syntax-object-expression\ 3780}#
+ #{x\ 4351}#)
+ (#{make-wrap\ 3797}#
+ (cdr #{ms\ 4354}#)
+ (if #{rib\ 4348}#
+ (cons #{rib\ 4348}#
+ (cdr #{s\ 4355}#))
+ (cdr #{s\ 4355}#)))
+ (#{syntax-object-module\ 3782}#
+ #{x\ 4351}#))
+ (#{make-syntax-object\ 3778}#
+ (#{syntax-object-expression\ 3780}#
+ #{x\ 4351}#)
+ (#{make-wrap\ 3797}#
+ (cons #{m\ 4352}# #{ms\ 4354}#)
+ (if #{rib\ 4348}#
+ (cons #{rib\ 4348}#
(cons 'shift
- #{s\ 1619}#))
- (cons (quote shift) #{s\ 1619}#)))
- (let ((#{pmod\ 1620}#
- (procedure-module
- #{p\ 1608}#)))
- (if #{pmod\ 1620}#
- (cons 'hygiene
- (module-name #{pmod\ 1620}#))
- '(hygiene guile)))))))
- (if (vector? #{x\ 1615}#)
- (let ((#{n\ 1621}#
- (vector-length #{x\ 1615}#)))
- (let ((#{v\ 1622}#
- (make-vector #{n\ 1621}#)))
- (letrec ((#{loop\ 1623}#
- (lambda (#{i\ 1624}#)
- (if (#{fx=\ 1256}#
- #{i\ 1624}#
- #{n\ 1621}#)
+ #{s\ 4355}#))
+ (cons (quote shift) #{s\ 4355}#)))
+ (cons 'hygiene
+ (cdr #{p\ 4344}#))))))
+ (if (vector? #{x\ 4351}#)
+ (let ((#{n\ 4356}#
+ (vector-length #{x\ 4351}#)))
+ (let ((#{v\ 4357}#
+ (make-vector #{n\ 4356}#)))
+ (letrec ((#{loop\ 4358}#
+ (lambda (#{i\ 4359}#)
+ (if (#{fx=\ 3752}#
+ #{i\ 4359}#
+ #{n\ 4356}#)
(begin
(if #f #f)
- #{v\ 1622}#)
+ #{v\ 4357}#)
(begin
(vector-set!
- #{v\ 1622}#
- #{i\ 1624}#
- (#{rebuild-macro-output\ 1614}#
+ #{v\ 4357}#
+ #{i\ 4359}#
+ (#{rebuild-macro-output\ 4350}#
(vector-ref
- #{x\ 1615}#
- #{i\ 1624}#)
- #{m\ 1616}#))
- (#{loop\ 1623}#
- (#{fx+\ 1254}#
- #{i\ 1624}#
+ #{x\ 4351}#
+ #{i\ 4359}#)
+ #{m\ 4352}#))
+ (#{loop\ 4358}#
+ (#{fx+\ 3750}#
+ #{i\ 4359}#
1)))))))
- (#{loop\ 1623}# 0))))
- (if (symbol? #{x\ 1615}#)
+ (#{loop\ 4358}# 0))))
+ (if (symbol? #{x\ 4351}#)
(syntax-violation
#f
"encountered raw symbol in macro output"
- (#{source-wrap\ 1326}#
- #{e\ 1609}#
- #{w\ 1611}#
- s
- #{mod\ 1613}#)
- #{x\ 1615}#)
- #{x\ 1615}#)))))))
- (#{rebuild-macro-output\ 1614}#
- (#{p\ 1608}#
- (#{wrap\ 1325}#
- #{e\ 1609}#
- (#{anti-mark\ 1312}# #{w\ 1611}#)
- #{mod\ 1613}#))
+ (#{source-wrap\ 3824}#
+ #{e\ 4345}#
+ #{w\ 4347}#
+ (#{wrap-subst\ 3799}# #{w\ 4347}#)
+ #{mod\ 4349}#)
+ #{x\ 4351}#)
+ #{x\ 4351}#)))))))
+ (#{rebuild-macro-output\ 4350}#
+ ((car #{p\ 4344}#)
+ (#{wrap\ 3823}#
+ #{e\ 4345}#
+ (#{anti-mark\ 3810}# #{w\ 4347}#)
+ #{mod\ 4349}#))
(string #\m)))))
- (#{chi-application\ 1335}#
- (lambda (#{x\ 1625}#
- #{e\ 1626}#
- #{r\ 1627}#
- #{w\ 1628}#
- #{s\ 1629}#
- #{mod\ 1630}#)
- ((lambda (#{tmp\ 1631}#)
- ((lambda (#{tmp\ 1632}#)
- (if #{tmp\ 1632}#
- (apply (lambda (#{e0\ 1633}# #{e1\ 1634}#)
- (#{build-application\ 1264}#
- #{s\ 1629}#
- #{x\ 1625}#
- (map (lambda (#{e\ 1635}#)
- (#{chi\ 1333}#
- #{e\ 1635}#
- #{r\ 1627}#
- #{w\ 1628}#
- #{mod\ 1630}#))
- #{e1\ 1634}#)))
- #{tmp\ 1632}#)
+ (#{chi-application\ 3833}#
+ (lambda (#{x\ 4360}#
+ #{e\ 4361}#
+ #{r\ 4362}#
+ #{w\ 4363}#
+ #{s\ 4364}#
+ #{mod\ 4365}#)
+ ((lambda (#{tmp\ 4366}#)
+ ((lambda (#{tmp\ 4367}#)
+ (if #{tmp\ 4367}#
+ (apply (lambda (#{e0\ 4368}# #{e1\ 4369}#)
+ (#{build-application\ 3760}#
+ #{s\ 4364}#
+ #{x\ 4360}#
+ (map (lambda (#{e\ 4370}#)
+ (#{chi\ 3831}#
+ #{e\ 4370}#
+ #{r\ 4362}#
+ #{w\ 4363}#
+ #{mod\ 4365}#))
+ #{e1\ 4369}#)))
+ #{tmp\ 4367}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1631}#)))
+ #{tmp\ 4366}#)))
($sc-dispatch
- #{tmp\ 1631}#
+ #{tmp\ 4366}#
'(any . each-any))))
- #{e\ 1626}#)))
- (#{chi-expr\ 1334}#
- (lambda (#{type\ 1637}#
- #{value\ 1638}#
- #{e\ 1639}#
- #{r\ 1640}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#)
- (if (memv #{type\ 1637}# (quote (lexical)))
- (#{build-lexical-reference\ 1266}#
+ #{e\ 4361}#)))
+ (#{chi-expr\ 3832}#
+ (lambda (#{type\ 4372}#
+ #{value\ 4373}#
+ #{e\ 4374}#
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#)
+ (if (memv #{type\ 4372}# (quote (lexical)))
+ (#{build-lexical-reference\ 3762}#
'value
- #{s\ 1642}#
- #{e\ 1639}#
- #{value\ 1638}#)
- (if (memv #{type\ 1637}# (quote (core core-form)))
- (#{value\ 1638}#
- #{e\ 1639}#
- #{r\ 1640}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#)
- (if (memv #{type\ 1637}# (quote (module-ref)))
+ #{s\ 4377}#
+ #{e\ 4374}#
+ #{value\ 4373}#)
+ (if (memv #{type\ 4372}# (quote (core core-form)))
+ (#{value\ 4373}#
+ #{e\ 4374}#
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#)
+ (if (memv #{type\ 4372}# (quote (module-ref)))
(call-with-values
- (lambda () (#{value\ 1638}# #{e\ 1639}#))
- (lambda (#{id\ 1644}# #{mod\ 1645}#)
- (#{build-global-reference\ 1269}#
- #{s\ 1642}#
- #{id\ 1644}#
- #{mod\ 1645}#)))
- (if (memv #{type\ 1637}# (quote (lexical-call)))
- (#{chi-application\ 1335}#
- (#{build-lexical-reference\ 1266}#
+ (lambda () (#{value\ 4373}# #{e\ 4374}#))
+ (lambda (#{id\ 4379}# #{mod\ 4380}#)
+ (#{build-global-reference\ 3765}#
+ #{s\ 4377}#
+ #{id\ 4379}#
+ #{mod\ 4380}#)))
+ (if (memv #{type\ 4372}# (quote (lexical-call)))
+ (#{chi-application\ 3833}#
+ (#{build-lexical-reference\ 3762}#
'fun
- (#{source-annotation\ 1288}# (car #{e\ 1639}#))
- (car #{e\ 1639}#)
- #{value\ 1638}#)
- #{e\ 1639}#
- #{r\ 1640}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#)
- (if (memv #{type\ 1637}# (quote (global-call)))
- (#{chi-application\ 1335}#
- (#{build-global-reference\ 1269}#
- (#{source-annotation\ 1288}# (car #{e\ 1639}#))
- (if (#{syntax-object?\ 1281}# #{value\ 1638}#)
- (#{syntax-object-expression\ 1282}#
- #{value\ 1638}#)
- #{value\ 1638}#)
- (if (#{syntax-object?\ 1281}# #{value\ 1638}#)
- (#{syntax-object-module\ 1284}# #{value\ 1638}#)
- #{mod\ 1643}#))
- #{e\ 1639}#
- #{r\ 1640}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#)
- (if (memv #{type\ 1637}# (quote (constant)))
- (#{build-data\ 1275}#
- #{s\ 1642}#
- (#{strip\ 1343}#
- (#{source-wrap\ 1326}#
- #{e\ 1639}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#)
+ (#{source-annotation\ 3786}# (car #{e\ 4374}#))
+ (car #{e\ 4374}#)
+ #{value\ 4373}#)
+ #{e\ 4374}#
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#)
+ (if (memv #{type\ 4372}# (quote (global-call)))
+ (#{chi-application\ 3833}#
+ (#{build-global-reference\ 3765}#
+ (#{source-annotation\ 3786}# (car #{e\ 4374}#))
+ (if (#{syntax-object?\ 3779}# #{value\ 4373}#)
+ (#{syntax-object-expression\ 3780}#
+ #{value\ 4373}#)
+ #{value\ 4373}#)
+ (if (#{syntax-object?\ 3779}# #{value\ 4373}#)
+ (#{syntax-object-module\ 3782}# #{value\ 4373}#)
+ #{mod\ 4378}#))
+ #{e\ 4374}#
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#)
+ (if (memv #{type\ 4372}# (quote (constant)))
+ (#{build-data\ 3773}#
+ #{s\ 4377}#
+ (#{strip\ 3844}#
+ (#{source-wrap\ 3824}#
+ #{e\ 4374}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#)
'(())))
- (if (memv #{type\ 1637}# (quote (global)))
- (#{build-global-reference\ 1269}#
- #{s\ 1642}#
- #{value\ 1638}#
- #{mod\ 1643}#)
- (if (memv #{type\ 1637}# (quote (call)))
- (#{chi-application\ 1335}#
- (#{chi\ 1333}#
- (car #{e\ 1639}#)
- #{r\ 1640}#
- #{w\ 1641}#
- #{mod\ 1643}#)
- #{e\ 1639}#
- #{r\ 1640}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#)
- (if (memv #{type\ 1637}# (quote (begin-form)))
- ((lambda (#{tmp\ 1646}#)
- ((lambda (#{tmp\ 1647}#)
- (if #{tmp\ 1647}#
- (apply (lambda (#{_\ 1648}#
- #{e1\ 1649}#
- #{e2\ 1650}#)
- (#{chi-sequence\ 1327}#
- (cons #{e1\ 1649}#
- #{e2\ 1650}#)
- #{r\ 1640}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#))
- #{tmp\ 1647}#)
+ (if (memv #{type\ 4372}# (quote (global)))
+ (#{build-global-reference\ 3765}#
+ #{s\ 4377}#
+ #{value\ 4373}#
+ #{mod\ 4378}#)
+ (if (memv #{type\ 4372}# (quote (call)))
+ (#{chi-application\ 3833}#
+ (#{chi\ 3831}#
+ (car #{e\ 4374}#)
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{mod\ 4378}#)
+ #{e\ 4374}#
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#)
+ (if (memv #{type\ 4372}# (quote (begin-form)))
+ ((lambda (#{tmp\ 4381}#)
+ ((lambda (#{tmp\ 4382}#)
+ (if #{tmp\ 4382}#
+ (apply (lambda (#{_\ 4383}#
+ #{e1\ 4384}#
+ #{e2\ 4385}#)
+ (#{chi-sequence\ 3825}#
+ (cons #{e1\ 4384}#
+ #{e2\ 4385}#)
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#))
+ #{tmp\ 4382}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1646}#)))
+ #{tmp\ 4381}#)))
($sc-dispatch
- #{tmp\ 1646}#
+ #{tmp\ 4381}#
'(any any . each-any))))
- #{e\ 1639}#)
- (if (memv #{type\ 1637}#
+ #{e\ 4374}#)
+ (if (memv #{type\ 4372}#
'(local-syntax-form))
- (#{chi-local-syntax\ 1339}#
- #{value\ 1638}#
- #{e\ 1639}#
- #{r\ 1640}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#
- #{chi-sequence\ 1327}#)
- (if (memv #{type\ 1637}#
+ (#{chi-local-syntax\ 3836}#
+ #{value\ 4373}#
+ #{e\ 4374}#
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#
+ #{chi-sequence\ 3825}#)
+ (if (memv #{type\ 4372}#
'(eval-when-form))
- ((lambda (#{tmp\ 1652}#)
- ((lambda (#{tmp\ 1653}#)
- (if #{tmp\ 1653}#
- (apply (lambda (#{_\ 1654}#
- #{x\ 1655}#
- #{e1\ 1656}#
- #{e2\ 1657}#)
- (let ((#{when-list\ 1658}#
- (#{chi-when-list\ 1330}#
- #{e\ 1639}#
- #{x\ 1655}#
- #{w\ 1641}#)))
+ ((lambda (#{tmp\ 4387}#)
+ ((lambda (#{tmp\ 4388}#)
+ (if #{tmp\ 4388}#
+ (apply (lambda (#{_\ 4389}#
+ #{x\ 4390}#
+ #{e1\ 4391}#
+ #{e2\ 4392}#)
+ (let ((#{when-list\ 4393}#
+ (#{chi-when-list\ 3828}#
+ #{e\ 4374}#
+ #{x\ 4390}#
+ #{w\ 4376}#)))
(if (memq 'eval
- #{when-list\ 1658}#)
- (#{chi-sequence\ 1327}#
- (cons #{e1\ 1656}#
- #{e2\ 1657}#)
- #{r\ 1640}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#)
- (#{chi-void\ 1341}#))))
- #{tmp\ 1653}#)
+ #{when-list\ 4393}#)
+ (#{chi-sequence\ 3825}#
+ (cons #{e1\ 4391}#
+ #{e2\ 4392}#)
+ #{r\ 4375}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#)
+ (#{chi-void\ 3838}#))))
+ #{tmp\ 4388}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1652}#)))
+ #{tmp\ 4387}#)))
($sc-dispatch
- #{tmp\ 1652}#
+ #{tmp\ 4387}#
'(any each-any any . each-any))))
- #{e\ 1639}#)
- (if (memv #{type\ 1637}#
+ #{e\ 4374}#)
+ (if (memv #{type\ 4372}#
'(define-form
define-syntax-form))
(syntax-violation
#f
"definition in expression context"
- #{e\ 1639}#
- (#{wrap\ 1325}#
- #{value\ 1638}#
- #{w\ 1641}#
- #{mod\ 1643}#))
- (if (memv #{type\ 1637}#
+ #{e\ 4374}#
+ (#{wrap\ 3823}#
+ #{value\ 4373}#
+ #{w\ 4376}#
+ #{mod\ 4378}#))
+ (if (memv #{type\ 4372}#
'(syntax))
(syntax-violation
#f
"reference to pattern variable outside syntax form"
- (#{source-wrap\ 1326}#
- #{e\ 1639}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#))
- (if (memv #{type\ 1637}#
+ (#{source-wrap\ 3824}#
+ #{e\ 4374}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#))
+ (if (memv #{type\ 4372}#
'(displaced-lexical))
(syntax-violation
#f
"reference to identifier outside its scope"
- (#{source-wrap\ 1326}#
- #{e\ 1639}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#))
+ (#{source-wrap\ 3824}#
+ #{e\ 4374}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#))
(syntax-violation
#f
"unexpected syntax"
- (#{source-wrap\ 1326}#
- #{e\ 1639}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#))))))))))))))))))
- (#{chi\ 1333}#
- (lambda (#{e\ 1661}#
- #{r\ 1662}#
- #{w\ 1663}#
- #{mod\ 1664}#)
+ (#{source-wrap\ 3824}#
+ #{e\ 4374}#
+ #{w\ 4376}#
+ #{s\ 4377}#
+ #{mod\ 4378}#))))))))))))))))))
+ (#{chi\ 3831}#
+ (lambda (#{e\ 4396}#
+ #{r\ 4397}#
+ #{w\ 4398}#
+ #{mod\ 4399}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{e\ 1661}#
- #{r\ 1662}#
- #{w\ 1663}#
- (#{source-annotation\ 1288}# #{e\ 1661}#)
+ (#{syntax-type\ 3829}#
+ #{e\ 4396}#
+ #{r\ 4397}#
+ #{w\ 4398}#
+ (#{source-annotation\ 3786}# #{e\ 4396}#)
#f
- #{mod\ 1664}#
+ #{mod\ 4399}#
#f))
- (lambda (#{type\ 1665}#
- #{value\ 1666}#
- #{e\ 1667}#
- #{w\ 1668}#
- #{s\ 1669}#
- #{mod\ 1670}#)
- (#{chi-expr\ 1334}#
- #{type\ 1665}#
- #{value\ 1666}#
- #{e\ 1667}#
- #{r\ 1662}#
- #{w\ 1668}#
- #{s\ 1669}#
- #{mod\ 1670}#)))))
- (#{chi-top\ 1332}#
- (lambda (#{e\ 1671}#
- #{r\ 1672}#
- #{w\ 1673}#
- #{m\ 1674}#
- #{esew\ 1675}#
- #{mod\ 1676}#)
+ (lambda (#{type\ 4400}#
+ #{value\ 4401}#
+ #{e\ 4402}#
+ #{w\ 4403}#
+ #{s\ 4404}#
+ #{mod\ 4405}#)
+ (#{chi-expr\ 3832}#
+ #{type\ 4400}#
+ #{value\ 4401}#
+ #{e\ 4402}#
+ #{r\ 4397}#
+ #{w\ 4403}#
+ #{s\ 4404}#
+ #{mod\ 4405}#)))))
+ (#{chi-top\ 3830}#
+ (lambda (#{e\ 4406}#
+ #{r\ 4407}#
+ #{w\ 4408}#
+ #{m\ 4409}#
+ #{esew\ 4410}#
+ #{mod\ 4411}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{e\ 1671}#
- #{r\ 1672}#
- #{w\ 1673}#
- (#{source-annotation\ 1288}# #{e\ 1671}#)
+ (#{syntax-type\ 3829}#
+ #{e\ 4406}#
+ #{r\ 4407}#
+ #{w\ 4408}#
+ (#{source-annotation\ 3786}# #{e\ 4406}#)
#f
- #{mod\ 1676}#
+ #{mod\ 4411}#
#f))
- (lambda (#{type\ 1684}#
- #{value\ 1685}#
- #{e\ 1686}#
- #{w\ 1687}#
- #{s\ 1688}#
- #{mod\ 1689}#)
- (if (memv #{type\ 1684}# (quote (begin-form)))
- ((lambda (#{tmp\ 1690}#)
- ((lambda (#{tmp\ 1691}#)
- (if #{tmp\ 1691}#
- (apply (lambda (#{_\ 1692}#) (#{chi-void\ 1341}#))
- #{tmp\ 1691}#)
- ((lambda (#{tmp\ 1693}#)
- (if #{tmp\ 1693}#
- (apply (lambda (#{_\ 1694}#
- #{e1\ 1695}#
- #{e2\ 1696}#)
- (#{chi-top-sequence\ 1328}#
- (cons #{e1\ 1695}# #{e2\ 1696}#)
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
- #{m\ 1674}#
- #{esew\ 1675}#
- #{mod\ 1689}#))
- #{tmp\ 1693}#)
+ (lambda (#{type\ 4419}#
+ #{value\ 4420}#
+ #{e\ 4421}#
+ #{w\ 4422}#
+ #{s\ 4423}#
+ #{mod\ 4424}#)
+ (if (memv #{type\ 4419}# (quote (begin-form)))
+ ((lambda (#{tmp\ 4425}#)
+ ((lambda (#{tmp\ 4426}#)
+ (if #{tmp\ 4426}#
+ (apply (lambda (#{_\ 4427}#) (#{chi-void\ 3838}#))
+ #{tmp\ 4426}#)
+ ((lambda (#{tmp\ 4428}#)
+ (if #{tmp\ 4428}#
+ (apply (lambda (#{_\ 4429}#
+ #{e1\ 4430}#
+ #{e2\ 4431}#)
+ (#{chi-top-sequence\ 3826}#
+ (cons #{e1\ 4430}# #{e2\ 4431}#)
+ #{r\ 4407}#
+ #{w\ 4422}#
+ #{s\ 4423}#
+ #{m\ 4409}#
+ #{esew\ 4410}#
+ #{mod\ 4424}#))
+ #{tmp\ 4428}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1690}#)))
+ #{tmp\ 4425}#)))
($sc-dispatch
- #{tmp\ 1690}#
+ #{tmp\ 4425}#
'(any any . each-any)))))
- ($sc-dispatch #{tmp\ 1690}# (quote (any)))))
- #{e\ 1686}#)
- (if (memv #{type\ 1684}# (quote (local-syntax-form)))
- (#{chi-local-syntax\ 1339}#
- #{value\ 1685}#
- #{e\ 1686}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
- #{mod\ 1689}#
- (lambda (#{body\ 1698}#
- #{r\ 1699}#
- #{w\ 1700}#
- #{s\ 1701}#
- #{mod\ 1702}#)
- (#{chi-top-sequence\ 1328}#
- #{body\ 1698}#
- #{r\ 1699}#
- #{w\ 1700}#
- #{s\ 1701}#
- #{m\ 1674}#
- #{esew\ 1675}#
- #{mod\ 1702}#)))
- (if (memv #{type\ 1684}# (quote (eval-when-form)))
- ((lambda (#{tmp\ 1703}#)
- ((lambda (#{tmp\ 1704}#)
- (if #{tmp\ 1704}#
- (apply (lambda (#{_\ 1705}#
- #{x\ 1706}#
- #{e1\ 1707}#
- #{e2\ 1708}#)
- (let ((#{when-list\ 1709}#
- (#{chi-when-list\ 1330}#
- #{e\ 1686}#
- #{x\ 1706}#
- #{w\ 1687}#))
- (#{body\ 1710}#
- (cons #{e1\ 1707}#
- #{e2\ 1708}#)))
- (if (eq? #{m\ 1674}# (quote e))
+ ($sc-dispatch #{tmp\ 4425}# (quote (any)))))
+ #{e\ 4421}#)
+ (if (memv #{type\ 4419}# (quote (local-syntax-form)))
+ (#{chi-local-syntax\ 3836}#
+ #{value\ 4420}#
+ #{e\ 4421}#
+ #{r\ 4407}#
+ #{w\ 4422}#
+ #{s\ 4423}#
+ #{mod\ 4424}#
+ (lambda (#{body\ 4433}#
+ #{r\ 4434}#
+ #{w\ 4435}#
+ #{s\ 4436}#
+ #{mod\ 4437}#)
+ (#{chi-top-sequence\ 3826}#
+ #{body\ 4433}#
+ #{r\ 4434}#
+ #{w\ 4435}#
+ #{s\ 4436}#
+ #{m\ 4409}#
+ #{esew\ 4410}#
+ #{mod\ 4437}#)))
+ (if (memv #{type\ 4419}# (quote (eval-when-form)))
+ ((lambda (#{tmp\ 4438}#)
+ ((lambda (#{tmp\ 4439}#)
+ (if #{tmp\ 4439}#
+ (apply (lambda (#{_\ 4440}#
+ #{x\ 4441}#
+ #{e1\ 4442}#
+ #{e2\ 4443}#)
+ (let ((#{when-list\ 4444}#
+ (#{chi-when-list\ 3828}#
+ #{e\ 4421}#
+ #{x\ 4441}#
+ #{w\ 4422}#))
+ (#{body\ 4445}#
+ (cons #{e1\ 4442}#
+ #{e2\ 4443}#)))
+ (if (eq? #{m\ 4409}# (quote e))
(if (memq 'eval
- #{when-list\ 1709}#)
- (#{chi-top-sequence\ 1328}#
- #{body\ 1710}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
+ #{when-list\ 4444}#)
+ (#{chi-top-sequence\ 3826}#
+ #{body\ 4445}#
+ #{r\ 4407}#
+ #{w\ 4422}#
+ #{s\ 4423}#
'e
'(eval)
- #{mod\ 1689}#)
- (#{chi-void\ 1341}#))
+ #{mod\ 4424}#)
+ (#{chi-void\ 3838}#))
(if (memq 'load
- #{when-list\ 1709}#)
- (if (let ((#{t\ 1713}#
+ #{when-list\ 4444}#)
+ (if (let ((#{t\ 4448}#
(memq 'compile
- #{when-list\ 1709}#)))
- (if #{t\ 1713}#
- #{t\ 1713}#
- (if (eq? #{m\ 1674}#
+ #{when-list\ 4444}#)))
+ (if #{t\ 4448}#
+ #{t\ 4448}#
+ (if (eq? #{m\ 4409}#
'c&e)
(memq 'eval
- #{when-list\ 1709}#)
+ #{when-list\ 4444}#)
#f)))
- (#{chi-top-sequence\ 1328}#
- #{body\ 1710}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
+ (#{chi-top-sequence\ 3826}#
+ #{body\ 4445}#
+ #{r\ 4407}#
+ #{w\ 4422}#
+ #{s\ 4423}#
'c&e
'(compile load)
- #{mod\ 1689}#)
- (if (memq #{m\ 1674}#
+ #{mod\ 4424}#)
+ (if (memq #{m\ 4409}#
'(c c&e))
- (#{chi-top-sequence\ 1328}#
- #{body\ 1710}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
+ (#{chi-top-sequence\ 3826}#
+ #{body\ 4445}#
+ #{r\ 4407}#
+ #{w\ 4422}#
+ #{s\ 4423}#
'c
'(load)
- #{mod\ 1689}#)
- (#{chi-void\ 1341}#)))
- (if (let ((#{t\ 1714}#
+ #{mod\ 4424}#)
+ (#{chi-void\ 3838}#)))
+ (if (let ((#{t\ 4449}#
(memq 'compile
- #{when-list\ 1709}#)))
- (if #{t\ 1714}#
- #{t\ 1714}#
- (if (eq? #{m\ 1674}#
+ #{when-list\ 4444}#)))
+ (if #{t\ 4449}#
+ #{t\ 4449}#
+ (if (eq? #{m\ 4409}#
'c&e)
(memq 'eval
- #{when-list\ 1709}#)
+ #{when-list\ 4444}#)
#f)))
(begin
- (#{top-level-eval-hook\ 1258}#
- (#{chi-top-sequence\ 1328}#
- #{body\ 1710}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
+ (#{top-level-eval-hook\ 3754}#
+ (#{chi-top-sequence\ 3826}#
+ #{body\ 4445}#
+ #{r\ 4407}#
+ #{w\ 4422}#
+ #{s\ 4423}#
'e
'(eval)
- #{mod\ 1689}#)
- #{mod\ 1689}#)
- (#{chi-void\ 1341}#))
- (#{chi-void\ 1341}#))))))
- #{tmp\ 1704}#)
+ #{mod\ 4424}#)
+ #{mod\ 4424}#)
+ (#{chi-void\ 3838}#))
+ (#{chi-void\ 3838}#))))))
+ #{tmp\ 4439}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1703}#)))
+ #{tmp\ 4438}#)))
($sc-dispatch
- #{tmp\ 1703}#
+ #{tmp\ 4438}#
'(any each-any any . each-any))))
- #{e\ 1686}#)
- (if (memv #{type\ 1684}#
+ #{e\ 4421}#)
+ (if (memv #{type\ 4419}#
'(define-syntax-form))
- (let ((#{n\ 1715}#
- (#{id-var-name\ 1319}#
- #{value\ 1685}#
- #{w\ 1687}#))
- (#{r\ 1716}#
- (#{macros-only-env\ 1293}# #{r\ 1672}#)))
- (if (memv #{m\ 1674}# (quote (c)))
- (if (memq (quote compile) #{esew\ 1675}#)
- (let ((#{e\ 1717}#
- (#{chi-install-global\ 1329}#
- #{n\ 1715}#
- (#{chi\ 1333}#
- #{e\ 1686}#
- #{r\ 1716}#
- #{w\ 1687}#
- #{mod\ 1689}#))))
+ (let ((#{n\ 4450}#
+ (#{id-var-name\ 3817}#
+ #{value\ 4420}#
+ #{w\ 4422}#))
+ (#{r\ 4451}#
+ (#{macros-only-env\ 3791}# #{r\ 4407}#)))
+ (if (memv #{m\ 4409}# (quote (c)))
+ (if (memq (quote compile) #{esew\ 4410}#)
+ (let ((#{e\ 4452}#
+ (#{chi-install-global\ 3827}#
+ #{n\ 4450}#
+ (#{chi\ 3831}#
+ #{e\ 4421}#
+ #{r\ 4451}#
+ #{w\ 4422}#
+ #{mod\ 4424}#))))
(begin
- (#{top-level-eval-hook\ 1258}#
- #{e\ 1717}#
- #{mod\ 1689}#)
- (if (memq (quote load) #{esew\ 1675}#)
- #{e\ 1717}#
- (#{chi-void\ 1341}#))))
- (if (memq (quote load) #{esew\ 1675}#)
- (#{chi-install-global\ 1329}#
- #{n\ 1715}#
- (#{chi\ 1333}#
- #{e\ 1686}#
- #{r\ 1716}#
- #{w\ 1687}#
- #{mod\ 1689}#))
- (#{chi-void\ 1341}#)))
- (if (memv #{m\ 1674}# (quote (c&e)))
- (let ((#{e\ 1718}#
- (#{chi-install-global\ 1329}#
- #{n\ 1715}#
- (#{chi\ 1333}#
- #{e\ 1686}#
- #{r\ 1716}#
- #{w\ 1687}#
- #{mod\ 1689}#))))
+ (#{top-level-eval-hook\ 3754}#
+ #{e\ 4452}#
+ #{mod\ 4424}#)
+ (if (memq (quote load) #{esew\ 4410}#)
+ #{e\ 4452}#
+ (#{chi-void\ 3838}#))))
+ (if (memq (quote load) #{esew\ 4410}#)
+ (#{chi-install-global\ 3827}#
+ #{n\ 4450}#
+ (#{chi\ 3831}#
+ #{e\ 4421}#
+ #{r\ 4451}#
+ #{w\ 4422}#
+ #{mod\ 4424}#))
+ (#{chi-void\ 3838}#)))
+ (if (memv #{m\ 4409}# (quote (c&e)))
+ (let ((#{e\ 4453}#
+ (#{chi-install-global\ 3827}#
+ #{n\ 4450}#
+ (#{chi\ 3831}#
+ #{e\ 4421}#
+ #{r\ 4451}#
+ #{w\ 4422}#
+ #{mod\ 4424}#))))
(begin
- (#{top-level-eval-hook\ 1258}#
- #{e\ 1718}#
- #{mod\ 1689}#)
- #{e\ 1718}#))
+ (#{top-level-eval-hook\ 3754}#
+ #{e\ 4453}#
+ #{mod\ 4424}#)
+ #{e\ 4453}#))
(begin
- (if (memq (quote eval) #{esew\ 1675}#)
- (#{top-level-eval-hook\ 1258}#
- (#{chi-install-global\ 1329}#
- #{n\ 1715}#
- (#{chi\ 1333}#
- #{e\ 1686}#
- #{r\ 1716}#
- #{w\ 1687}#
- #{mod\ 1689}#))
- #{mod\ 1689}#))
- (#{chi-void\ 1341}#)))))
- (if (memv #{type\ 1684}# (quote (define-form)))
- (let ((#{n\ 1719}#
- (#{id-var-name\ 1319}#
- #{value\ 1685}#
- #{w\ 1687}#)))
- (let ((#{type\ 1720}#
- (#{binding-type\ 1289}#
- (#{lookup\ 1294}#
- #{n\ 1719}#
- #{r\ 1672}#
- #{mod\ 1689}#))))
- (if (memv #{type\ 1720}#
+ (if (memq (quote eval) #{esew\ 4410}#)
+ (#{top-level-eval-hook\ 3754}#
+ (#{chi-install-global\ 3827}#
+ #{n\ 4450}#
+ (#{chi\ 3831}#
+ #{e\ 4421}#
+ #{r\ 4451}#
+ #{w\ 4422}#
+ #{mod\ 4424}#))
+ #{mod\ 4424}#))
+ (#{chi-void\ 3838}#)))))
+ (if (memv #{type\ 4419}# (quote (define-form)))
+ (let ((#{n\ 4454}#
+ (#{id-var-name\ 3817}#
+ #{value\ 4420}#
+ #{w\ 4422}#)))
+ (let ((#{type\ 4455}#
+ (#{binding-type\ 3787}#
+ (#{lookup\ 3792}#
+ #{n\ 4454}#
+ #{r\ 4407}#
+ #{mod\ 4424}#))))
+ (if (memv #{type\ 4455}#
'(global core macro module-ref))
(begin
(if (if (not (module-local-variable
(current-module)
- #{n\ 1719}#))
+ #{n\ 4454}#))
(current-module)
#f)
- (let ((#{old\ 1721}#
+ (let ((#{old\ 4456}#
(module-variable
(current-module)
- #{n\ 1719}#)))
+ #{n\ 4454}#)))
(module-define!
(current-module)
- #{n\ 1719}#
- (if (variable? #{old\ 1721}#)
- (variable-ref #{old\ 1721}#)
+ #{n\ 4454}#
+ (if (variable? #{old\ 4456}#)
+ (variable-ref #{old\ 4456}#)
#f))))
- (let ((#{x\ 1722}#
- (#{build-global-definition\ 1272}#
- #{s\ 1688}#
- #{n\ 1719}#
- (#{chi\ 1333}#
- #{e\ 1686}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{mod\ 1689}#))))
+ (let ((#{x\ 4457}#
+ (#{build-global-definition\ 3768}#
+ #{s\ 4423}#
+ #{n\ 4454}#
+ (#{chi\ 3831}#
+ #{e\ 4421}#
+ #{r\ 4407}#
+ #{w\ 4422}#
+ #{mod\ 4424}#))))
(begin
- (if (eq? #{m\ 1674}# (quote c&e))
- (#{top-level-eval-hook\ 1258}#
- #{x\ 1722}#
- #{mod\ 1689}#))
- #{x\ 1722}#)))
- (if (memv #{type\ 1720}#
+ (if (eq? #{m\ 4409}# (quote c&e))
+ (#{top-level-eval-hook\ 3754}#
+ #{x\ 4457}#
+ #{mod\ 4424}#))
+ #{x\ 4457}#)))
+ (if (memv #{type\ 4455}#
'(displaced-lexical))
(syntax-violation
#f
"identifier out of context"
- #{e\ 1686}#
- (#{wrap\ 1325}#
- #{value\ 1685}#
- #{w\ 1687}#
- #{mod\ 1689}#))
+ #{e\ 4421}#
+ (#{wrap\ 3823}#
+ #{value\ 4420}#
+ #{w\ 4422}#
+ #{mod\ 4424}#))
(syntax-violation
#f
"cannot define keyword at top level"
- #{e\ 1686}#
- (#{wrap\ 1325}#
- #{value\ 1685}#
- #{w\ 1687}#
- #{mod\ 1689}#))))))
- (let ((#{x\ 1723}#
- (#{chi-expr\ 1334}#
- #{type\ 1684}#
- #{value\ 1685}#
- #{e\ 1686}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
- #{mod\ 1689}#)))
+ #{e\ 4421}#
+ (#{wrap\ 3823}#
+ #{value\ 4420}#
+ #{w\ 4422}#
+ #{mod\ 4424}#))))))
+ (let ((#{x\ 4458}#
+ (#{chi-expr\ 3832}#
+ #{type\ 4419}#
+ #{value\ 4420}#
+ #{e\ 4421}#
+ #{r\ 4407}#
+ #{w\ 4422}#
+ #{s\ 4423}#
+ #{mod\ 4424}#)))
(begin
- (if (eq? #{m\ 1674}# (quote c&e))
- (#{top-level-eval-hook\ 1258}#
- #{x\ 1723}#
- #{mod\ 1689}#))
- #{x\ 1723}#)))))))))))
- (#{syntax-type\ 1331}#
- (lambda (#{e\ 1724}#
- #{r\ 1725}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{rib\ 1728}#
- #{mod\ 1729}#
- #{for-car?\ 1730}#)
- (if (symbol? #{e\ 1724}#)
- (let ((#{n\ 1731}#
- (#{id-var-name\ 1319}# #{e\ 1724}# #{w\ 1726}#)))
- (let ((#{b\ 1732}#
- (#{lookup\ 1294}#
- #{n\ 1731}#
- #{r\ 1725}#
- #{mod\ 1729}#)))
- (let ((#{type\ 1733}#
- (#{binding-type\ 1289}# #{b\ 1732}#)))
- (if (memv #{type\ 1733}# (quote (lexical)))
+ (if (eq? #{m\ 4409}# (quote c&e))
+ (#{top-level-eval-hook\ 3754}#
+ #{x\ 4458}#
+ #{mod\ 4424}#))
+ #{x\ 4458}#)))))))))))
+ (#{syntax-type\ 3829}#
+ (lambda (#{e\ 4459}#
+ #{r\ 4460}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{rib\ 4463}#
+ #{mod\ 4464}#
+ #{for-car?\ 4465}#)
+ (if (symbol? #{e\ 4459}#)
+ (let ((#{n\ 4466}#
+ (#{id-var-name\ 3817}# #{e\ 4459}# #{w\ 4461}#)))
+ (let ((#{b\ 4467}#
+ (#{lookup\ 3792}#
+ #{n\ 4466}#
+ #{r\ 4460}#
+ #{mod\ 4464}#)))
+ (let ((#{type\ 4468}#
+ (#{binding-type\ 3787}# #{b\ 4467}#)))
+ (if (memv #{type\ 4468}# (quote (lexical)))
(values
- #{type\ 1733}#
- (#{binding-value\ 1290}# #{b\ 1732}#)
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{type\ 1733}# (quote (global)))
+ #{type\ 4468}#
+ (#{binding-value\ 3788}# #{b\ 4467}#)
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (if (memv #{type\ 4468}# (quote (global)))
(values
- #{type\ 1733}#
- #{n\ 1731}#
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{type\ 1733}# (quote (macro)))
- (if #{for-car?\ 1730}#
+ #{type\ 4468}#
+ #{n\ 4466}#
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (if (memv #{type\ 4468}# (quote (macro)))
+ (if #{for-car?\ 4465}#
(values
- #{type\ 1733}#
- (#{binding-value\ 1290}# #{b\ 1732}#)
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (#{syntax-type\ 1331}#
- (#{chi-macro\ 1336}#
- (#{binding-value\ 1290}# #{b\ 1732}#)
- #{e\ 1724}#
- #{r\ 1725}#
- #{w\ 1726}#
- #{rib\ 1728}#
- #{mod\ 1729}#)
- #{r\ 1725}#
+ #{type\ 4468}#
+ (#{binding-value\ 3788}# #{b\ 4467}#)
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (#{syntax-type\ 3829}#
+ (#{chi-macro\ 3834}#
+ (#{binding-value\ 3788}# #{b\ 4467}#)
+ #{e\ 4459}#
+ #{r\ 4460}#
+ #{w\ 4461}#
+ #{rib\ 4463}#
+ #{mod\ 4464}#)
+ #{r\ 4460}#
'(())
- #{s\ 1727}#
- #{rib\ 1728}#
- #{mod\ 1729}#
+ #{s\ 4462}#
+ #{rib\ 4463}#
+ #{mod\ 4464}#
#f))
(values
- #{type\ 1733}#
- (#{binding-value\ 1290}# #{b\ 1732}#)
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)))))))
- (if (pair? #{e\ 1724}#)
- (let ((#{first\ 1734}# (car #{e\ 1724}#)))
+ #{type\ 4468}#
+ (#{binding-value\ 3788}# #{b\ 4467}#)
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)))))))
+ (if (pair? #{e\ 4459}#)
+ (let ((#{first\ 4469}# (car #{e\ 4459}#)))
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{first\ 1734}#
- #{r\ 1725}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{rib\ 1728}#
- #{mod\ 1729}#
+ (#{syntax-type\ 3829}#
+ #{first\ 4469}#
+ #{r\ 4460}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{rib\ 4463}#
+ #{mod\ 4464}#
#t))
- (lambda (#{ftype\ 1735}#
- #{fval\ 1736}#
- #{fe\ 1737}#
- #{fw\ 1738}#
- #{fs\ 1739}#
- #{fmod\ 1740}#)
- (if (memv #{ftype\ 1735}# (quote (lexical)))
+ (lambda (#{ftype\ 4470}#
+ #{fval\ 4471}#
+ #{fe\ 4472}#
+ #{fw\ 4473}#
+ #{fs\ 4474}#
+ #{fmod\ 4475}#)
+ (if (memv #{ftype\ 4470}# (quote (lexical)))
(values
'lexical-call
- #{fval\ 1736}#
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}# (quote (global)))
+ #{fval\ 4471}#
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (if (memv #{ftype\ 4470}# (quote (global)))
(values
'global-call
- (#{make-syntax-object\ 1280}#
- #{fval\ 1736}#
- #{w\ 1726}#
- #{fmod\ 1740}#)
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}# (quote (macro)))
- (#{syntax-type\ 1331}#
- (#{chi-macro\ 1336}#
- #{fval\ 1736}#
- #{e\ 1724}#
- #{r\ 1725}#
- #{w\ 1726}#
- #{rib\ 1728}#
- #{mod\ 1729}#)
- #{r\ 1725}#
+ (#{make-syntax-object\ 3778}#
+ #{fval\ 4471}#
+ #{w\ 4461}#
+ #{fmod\ 4475}#)
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (if (memv #{ftype\ 4470}# (quote (macro)))
+ (#{syntax-type\ 3829}#
+ (#{chi-macro\ 3834}#
+ #{fval\ 4471}#
+ #{e\ 4459}#
+ #{r\ 4460}#
+ #{w\ 4461}#
+ #{rib\ 4463}#
+ #{mod\ 4464}#)
+ #{r\ 4460}#
'(())
- #{s\ 1727}#
- #{rib\ 1728}#
- #{mod\ 1729}#
- #{for-car?\ 1730}#)
- (if (memv #{ftype\ 1735}# (quote (module-ref)))
+ #{s\ 4462}#
+ #{rib\ 4463}#
+ #{mod\ 4464}#
+ #{for-car?\ 4465}#)
+ (if (memv #{ftype\ 4470}# (quote (module-ref)))
(call-with-values
- (lambda () (#{fval\ 1736}# #{e\ 1724}#))
- (lambda (#{sym\ 1741}# #{mod\ 1742}#)
- (#{syntax-type\ 1331}#
- #{sym\ 1741}#
- #{r\ 1725}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{rib\ 1728}#
- #{mod\ 1742}#
- #{for-car?\ 1730}#)))
- (if (memv #{ftype\ 1735}# (quote (core)))
+ (lambda () (#{fval\ 4471}# #{e\ 4459}#))
+ (lambda (#{sym\ 4476}# #{mod\ 4477}#)
+ (#{syntax-type\ 3829}#
+ #{sym\ 4476}#
+ #{r\ 4460}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{rib\ 4463}#
+ #{mod\ 4477}#
+ #{for-car?\ 4465}#)))
+ (if (memv #{ftype\ 4470}# (quote (core)))
(values
'core-form
- #{fval\ 1736}#
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}#
+ #{fval\ 4471}#
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (if (memv #{ftype\ 4470}#
'(local-syntax))
(values
'local-syntax-form
- #{fval\ 1736}#
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}# (quote (begin)))
+ #{fval\ 4471}#
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (if (memv #{ftype\ 4470}# (quote (begin)))
(values
'begin-form
#f
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}#
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (if (memv #{ftype\ 4470}#
'(eval-when))
(values
'eval-when-form
#f
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}#
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
+ (if (memv #{ftype\ 4470}#
'(define))
- ((lambda (#{tmp\ 1743}#)
- ((lambda (#{tmp\ 1744}#)
- (if (if #{tmp\ 1744}#
- (apply (lambda (#{_\ 1745}#
- #{name\ 1746}#
- #{val\ 1747}#)
- (#{id?\ 1297}#
- #{name\ 1746}#))
- #{tmp\ 1744}#)
+ ((lambda (#{tmp\ 4478}#)
+ ((lambda (#{tmp\ 4479}#)
+ (if (if #{tmp\ 4479}#
+ (apply (lambda (#{_\ 4480}#
+ #{name\ 4481}#
+ #{val\ 4482}#)
+ (#{id?\ 3795}#
+ #{name\ 4481}#))
+ #{tmp\ 4479}#)
#f)
- (apply (lambda (#{_\ 1748}#
- #{name\ 1749}#
- #{val\ 1750}#)
+ (apply (lambda (#{_\ 4483}#
+ #{name\ 4484}#
+ #{val\ 4485}#)
(values
'define-form
- #{name\ 1749}#
- #{val\ 1750}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#))
- #{tmp\ 1744}#)
- ((lambda (#{tmp\ 1751}#)
- (if (if #{tmp\ 1751}#
- (apply (lambda (#{_\ 1752}#
- #{name\ 1753}#
- #{args\ 1754}#
- #{e1\ 1755}#
- #{e2\ 1756}#)
- (if (#{id?\ 1297}#
- #{name\ 1753}#)
- (#{valid-bound-ids?\ 1322}#
- (#{lambda-var-list\ 1345}#
- #{args\ 1754}#))
+ #{name\ 4484}#
+ #{val\ 4485}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#))
+ #{tmp\ 4479}#)
+ ((lambda (#{tmp\ 4486}#)
+ (if (if #{tmp\ 4486}#
+ (apply (lambda (#{_\ 4487}#
+ #{name\ 4488}#
+ #{args\ 4489}#
+ #{e1\ 4490}#
+ #{e2\ 4491}#)
+ (if (#{id?\ 3795}#
+ #{name\ 4488}#)
+ (#{valid-bound-ids?\ 3820}#
+ (#{lambda-var-list\ 3846}#
+ #{args\ 4489}#))
#f))
- #{tmp\ 1751}#)
+ #{tmp\ 4486}#)
#f)
- (apply (lambda (#{_\ 1757}#
- #{name\ 1758}#
- #{args\ 1759}#
- #{e1\ 1760}#
- #{e2\ 1761}#)
+ (apply (lambda (#{_\ 4492}#
+ #{name\ 4493}#
+ #{args\ 4494}#
+ #{e1\ 4495}#
+ #{e2\ 4496}#)
(values
'define-form
- (#{wrap\ 1325}#
- #{name\ 1758}#
- #{w\ 1726}#
- #{mod\ 1729}#)
- (#{decorate-source\ 1262}#
+ (#{wrap\ 3823}#
+ #{name\ 4493}#
+ #{w\ 4461}#
+ #{mod\ 4464}#)
+ (#{decorate-source\ 3758}#
(cons '#(syntax-object
lambda
((top)
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
"i")))
(hygiene
guile))
- (#{wrap\ 1325}#
- (cons #{args\ 1759}#
- (cons #{e1\ 1760}#
- #{e2\ 1761}#))
- #{w\ 1726}#
- #{mod\ 1729}#))
- #{s\ 1727}#)
+ (#{wrap\ 3823}#
+ (cons #{args\ 4494}#
+ (cons #{e1\ 4495}#
+ #{e2\ 4496}#))
+ #{w\ 4461}#
+ #{mod\ 4464}#))
+ #{s\ 4462}#)
'(())
- #{s\ 1727}#
- #{mod\ 1729}#))
- #{tmp\ 1751}#)
- ((lambda (#{tmp\ 1763}#)
- (if (if #{tmp\ 1763}#
- (apply (lambda (#{_\ 1764}#
- #{name\ 1765}#)
- (#{id?\ 1297}#
- #{name\ 1765}#))
- #{tmp\ 1763}#)
+ #{s\ 4462}#
+ #{mod\ 4464}#))
+ #{tmp\ 4486}#)
+ ((lambda (#{tmp\ 4498}#)
+ (if (if #{tmp\ 4498}#
+ (apply (lambda (#{_\ 4499}#
+ #{name\ 4500}#)
+ (#{id?\ 3795}#
+ #{name\ 4500}#))
+ #{tmp\ 4498}#)
#f)
- (apply (lambda (#{_\ 1766}#
- #{name\ 1767}#)
+ (apply (lambda (#{_\ 4501}#
+ #{name\ 4502}#)
(values
'define-form
- (#{wrap\ 1325}#
- #{name\ 1767}#
- #{w\ 1726}#
- #{mod\ 1729}#)
+ (#{wrap\ 3823}#
+ #{name\ 4502}#
+ #{w\ 4461}#
+ #{mod\ 4464}#)
'(#(syntax-object
if
((top)
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
(hygiene
guile)))
'(())
- #{s\ 1727}#
- #{mod\ 1729}#))
- #{tmp\ 1763}#)
+ #{s\ 4462}#
+ #{mod\ 4464}#))
+ #{tmp\ 4498}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1743}#)))
+ #{tmp\ 4478}#)))
($sc-dispatch
- #{tmp\ 1743}#
+ #{tmp\ 4478}#
'(any any)))))
($sc-dispatch
- #{tmp\ 1743}#
+ #{tmp\ 4478}#
'(any (any . any)
any
.
each-any)))))
($sc-dispatch
- #{tmp\ 1743}#
+ #{tmp\ 4478}#
'(any any any))))
- #{e\ 1724}#)
- (if (memv #{ftype\ 1735}#
+ #{e\ 4459}#)
+ (if (memv #{ftype\ 4470}#
'(define-syntax))
- ((lambda (#{tmp\ 1768}#)
- ((lambda (#{tmp\ 1769}#)
- (if (if #{tmp\ 1769}#
- (apply (lambda (#{_\ 1770}#
- #{name\ 1771}#
- #{val\ 1772}#)
- (#{id?\ 1297}#
- #{name\ 1771}#))
- #{tmp\ 1769}#)
+ ((lambda (#{tmp\ 4503}#)
+ ((lambda (#{tmp\ 4504}#)
+ (if (if #{tmp\ 4504}#
+ (apply (lambda (#{_\ 4505}#
+ #{name\ 4506}#
+ #{val\ 4507}#)
+ (#{id?\ 3795}#
+ #{name\ 4506}#))
+ #{tmp\ 4504}#)
#f)
- (apply (lambda (#{_\ 1773}#
- #{name\ 1774}#
- #{val\ 1775}#)
+ (apply (lambda (#{_\ 4508}#
+ #{name\ 4509}#
+ #{val\ 4510}#)
(values
'define-syntax-form
- #{name\ 1774}#
- #{val\ 1775}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#))
- #{tmp\ 1769}#)
+ #{name\ 4509}#
+ #{val\ 4510}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#))
+ #{tmp\ 4504}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1768}#)))
+ #{tmp\ 4503}#)))
($sc-dispatch
- #{tmp\ 1768}#
+ #{tmp\ 4503}#
'(any any any))))
- #{e\ 1724}#)
+ #{e\ 4459}#)
(values
'call
#f
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#))))))))))))))
- (if (#{syntax-object?\ 1281}# #{e\ 1724}#)
- (#{syntax-type\ 1331}#
- (#{syntax-object-expression\ 1282}# #{e\ 1724}#)
- #{r\ 1725}#
- (#{join-wraps\ 1316}#
- #{w\ 1726}#
- (#{syntax-object-wrap\ 1283}# #{e\ 1724}#))
- #{s\ 1727}#
- #{rib\ 1728}#
- (let ((#{t\ 1776}#
- (#{syntax-object-module\ 1284}# #{e\ 1724}#)))
- (if #{t\ 1776}# #{t\ 1776}# #{mod\ 1729}#))
- #{for-car?\ 1730}#)
- (if (self-evaluating? #{e\ 1724}#)
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#))))))))))))))
+ (if (#{syntax-object?\ 3779}# #{e\ 4459}#)
+ (#{syntax-type\ 3829}#
+ (#{syntax-object-expression\ 3780}# #{e\ 4459}#)
+ #{r\ 4460}#
+ (#{join-wraps\ 3814}#
+ #{w\ 4461}#
+ (#{syntax-object-wrap\ 3781}# #{e\ 4459}#))
+ #{s\ 4462}#
+ #{rib\ 4463}#
+ (let ((#{t\ 4511}#
+ (#{syntax-object-module\ 3782}# #{e\ 4459}#)))
+ (if #{t\ 4511}# #{t\ 4511}# #{mod\ 4464}#))
+ #{for-car?\ 4465}#)
+ (if (self-evaluating? #{e\ 4459}#)
(values
'constant
#f
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)
(values
'other
#f
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)))))))
- (#{chi-when-list\ 1330}#
- (lambda (#{e\ 1777}# #{when-list\ 1778}# #{w\ 1779}#)
- (letrec ((#{f\ 1780}#
- (lambda (#{when-list\ 1781}# #{situations\ 1782}#)
- (if (null? #{when-list\ 1781}#)
- #{situations\ 1782}#
- (#{f\ 1780}#
- (cdr #{when-list\ 1781}#)
- (cons (let ((#{x\ 1783}#
- (car #{when-list\ 1781}#)))
- (if (#{free-id=?\ 1320}#
- #{x\ 1783}#
+ #{e\ 4459}#
+ #{w\ 4461}#
+ #{s\ 4462}#
+ #{mod\ 4464}#)))))))
+ (#{chi-when-list\ 3828}#
+ (lambda (#{e\ 4512}# #{when-list\ 4513}# #{w\ 4514}#)
+ (letrec ((#{f\ 4515}#
+ (lambda (#{when-list\ 4516}# #{situations\ 4517}#)
+ (if (null? #{when-list\ 4516}#)
+ #{situations\ 4517}#
+ (#{f\ 4515}#
+ (cdr #{when-list\ 4516}#)
+ (cons (let ((#{x\ 4518}#
+ (car #{when-list\ 4516}#)))
+ (if (#{free-id=?\ 3818}#
+ #{x\ 4518}#
'#(syntax-object
compile
((top)
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
("i" "i")))
(hygiene guile)))
'compile
- (if (#{free-id=?\ 1320}#
- #{x\ 1783}#
+ (if (#{free-id=?\ 3818}#
+ #{x\ 4518}#
'#(syntax-object
load
((top)
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
("i" "i")))
(hygiene guile)))
'load
- (if (#{free-id=?\ 1320}#
- #{x\ 1783}#
+ (if (#{free-id=?\ 3818}#
+ #{x\ 4518}#
'#(syntax-object
eval
((top)
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
(syntax-violation
'eval-when
"invalid situation"
- #{e\ 1777}#
- (#{wrap\ 1325}#
- #{x\ 1783}#
- #{w\ 1779}#
+ #{e\ 4512}#
+ (#{wrap\ 3823}#
+ #{x\ 4518}#
+ #{w\ 4514}#
#f))))))
- #{situations\ 1782}#))))))
- (#{f\ 1780}# #{when-list\ 1778}# (quote ())))))
- (#{chi-install-global\ 1329}#
- (lambda (#{name\ 1784}# #{e\ 1785}#)
- (#{build-global-definition\ 1272}#
+ #{situations\ 4517}#))))))
+ (#{f\ 4515}# #{when-list\ 4513}# (quote ())))))
+ (#{chi-install-global\ 3827}#
+ (lambda (#{name\ 4519}# #{e\ 4520}#)
+ (#{build-global-definition\ 3768}#
#f
- #{name\ 1784}#
- (if (let ((#{v\ 1786}#
+ #{name\ 4519}#
+ (if (let ((#{v\ 4521}#
(module-variable
(current-module)
- #{name\ 1784}#)))
- (if #{v\ 1786}#
- (if (variable-bound? #{v\ 1786}#)
- (if (macro? (variable-ref #{v\ 1786}#))
- (not (eq? (macro-type (variable-ref #{v\ 1786}#))
+ #{name\ 4519}#)))
+ (if #{v\ 4521}#
+ (if (variable-bound? #{v\ 4521}#)
+ (if (macro? (variable-ref #{v\ 4521}#))
+ (not (eq? (macro-type (variable-ref #{v\ 4521}#))
'syncase-macro))
#f)
#f)
#f))
- (#{build-application\ 1264}#
+ (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 3772}#
#f
'make-extended-syncase-macro)
- (list (#{build-application\ 1264}#
+ (list (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}# #f (quote module-ref))
- (list (#{build-application\ 1264}#
+ (#{build-primref\ 3772}# #f (quote module-ref))
+ (list (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 3772}#
#f
'current-module)
'())
- (#{build-data\ 1275}# #f #{name\ 1784}#)))
- (#{build-data\ 1275}# #f (quote macro))
- #{e\ 1785}#))
- (#{build-application\ 1264}#
+ (#{build-data\ 3773}# #f #{name\ 4519}#)))
+ (#{build-data\ 3773}# #f (quote macro))
+ (#{build-application\ 3760}#
+ #f
+ (#{build-primref\ 3772}# #f (quote cons))
+ (list #{e\ 4520}#
+ (#{build-application\ 3760}#
+ #f
+ (#{build-primref\ 3772}#
+ #f
+ 'module-name)
+ (list (#{build-application\ 3760}#
+ #f
+ (#{build-primref\ 3772}#
+ #f
+ 'current-module)
+ '())))))))
+ (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 3772}#
#f
'make-syncase-macro)
- (list (#{build-data\ 1275}# #f (quote macro))
- #{e\ 1785}#))))))
- (#{chi-top-sequence\ 1328}#
- (lambda (#{body\ 1787}#
- #{r\ 1788}#
- #{w\ 1789}#
- #{s\ 1790}#
- #{m\ 1791}#
- #{esew\ 1792}#
- #{mod\ 1793}#)
- (#{build-sequence\ 1276}#
- #{s\ 1790}#
- (letrec ((#{dobody\ 1794}#
- (lambda (#{body\ 1795}#
- #{r\ 1796}#
- #{w\ 1797}#
- #{m\ 1798}#
- #{esew\ 1799}#
- #{mod\ 1800}#)
- (if (null? #{body\ 1795}#)
+ (list (#{build-data\ 3773}# #f (quote macro))
+ (#{build-application\ 3760}#
+ #f
+ (#{build-primref\ 3772}# #f (quote cons))
+ (list #{e\ 4520}#
+ (#{build-application\ 3760}#
+ #f
+ (#{build-primref\ 3772}#
+ #f
+ 'module-name)
+ (list (#{build-application\ 3760}#
+ #f
+ (#{build-primref\ 3772}#
+ #f
+ 'current-module)
+ '())))))))))))
+ (#{chi-top-sequence\ 3826}#
+ (lambda (#{body\ 4522}#
+ #{r\ 4523}#
+ #{w\ 4524}#
+ #{s\ 4525}#
+ #{m\ 4526}#
+ #{esew\ 4527}#
+ #{mod\ 4528}#)
+ (#{build-sequence\ 3774}#
+ #{s\ 4525}#
+ (letrec ((#{dobody\ 4529}#
+ (lambda (#{body\ 4530}#
+ #{r\ 4531}#
+ #{w\ 4532}#
+ #{m\ 4533}#
+ #{esew\ 4534}#
+ #{mod\ 4535}#)
+ (if (null? #{body\ 4530}#)
'()
- (let ((#{first\ 1801}#
- (#{chi-top\ 1332}#
- (car #{body\ 1795}#)
- #{r\ 1796}#
- #{w\ 1797}#
- #{m\ 1798}#
- #{esew\ 1799}#
- #{mod\ 1800}#)))
- (cons #{first\ 1801}#
- (#{dobody\ 1794}#
- (cdr #{body\ 1795}#)
- #{r\ 1796}#
- #{w\ 1797}#
- #{m\ 1798}#
- #{esew\ 1799}#
- #{mod\ 1800}#)))))))
- (#{dobody\ 1794}#
- #{body\ 1787}#
- #{r\ 1788}#
- #{w\ 1789}#
- #{m\ 1791}#
- #{esew\ 1792}#
- #{mod\ 1793}#)))))
- (#{chi-sequence\ 1327}#
- (lambda (#{body\ 1802}#
- #{r\ 1803}#
- #{w\ 1804}#
- #{s\ 1805}#
- #{mod\ 1806}#)
- (#{build-sequence\ 1276}#
- #{s\ 1805}#
- (letrec ((#{dobody\ 1807}#
- (lambda (#{body\ 1808}#
- #{r\ 1809}#
- #{w\ 1810}#
- #{mod\ 1811}#)
- (if (null? #{body\ 1808}#)
+ (let ((#{first\ 4536}#
+ (#{chi-top\ 3830}#
+ (car #{body\ 4530}#)
+ #{r\ 4531}#
+ #{w\ 4532}#
+ #{m\ 4533}#
+ #{esew\ 4534}#
+ #{mod\ 4535}#)))
+ (cons #{first\ 4536}#
+ (#{dobody\ 4529}#
+ (cdr #{body\ 4530}#)
+ #{r\ 4531}#
+ #{w\ 4532}#
+ #{m\ 4533}#
+ #{esew\ 4534}#
+ #{mod\ 4535}#)))))))
+ (#{dobody\ 4529}#
+ #{body\ 4522}#
+ #{r\ 4523}#
+ #{w\ 4524}#
+ #{m\ 4526}#
+ #{esew\ 4527}#
+ #{mod\ 4528}#)))))
+ (#{chi-sequence\ 3825}#
+ (lambda (#{body\ 4537}#
+ #{r\ 4538}#
+ #{w\ 4539}#
+ #{s\ 4540}#
+ #{mod\ 4541}#)
+ (#{build-sequence\ 3774}#
+ #{s\ 4540}#
+ (letrec ((#{dobody\ 4542}#
+ (lambda (#{body\ 4543}#
+ #{r\ 4544}#
+ #{w\ 4545}#
+ #{mod\ 4546}#)
+ (if (null? #{body\ 4543}#)
'()
- (let ((#{first\ 1812}#
- (#{chi\ 1333}#
- (car #{body\ 1808}#)
- #{r\ 1809}#
- #{w\ 1810}#
- #{mod\ 1811}#)))
- (cons #{first\ 1812}#
- (#{dobody\ 1807}#
- (cdr #{body\ 1808}#)
- #{r\ 1809}#
- #{w\ 1810}#
- #{mod\ 1811}#)))))))
- (#{dobody\ 1807}#
- #{body\ 1802}#
- #{r\ 1803}#
- #{w\ 1804}#
- #{mod\ 1806}#)))))
- (#{source-wrap\ 1326}#
- (lambda (#{x\ 1813}#
- #{w\ 1814}#
- #{s\ 1815}#
- #{defmod\ 1816}#)
- (#{wrap\ 1325}#
- (#{decorate-source\ 1262}#
- #{x\ 1813}#
- #{s\ 1815}#)
- #{w\ 1814}#
- #{defmod\ 1816}#)))
- (#{wrap\ 1325}#
- (lambda (#{x\ 1817}# #{w\ 1818}# #{defmod\ 1819}#)
- (if (if (null? (#{wrap-marks\ 1300}# #{w\ 1818}#))
- (null? (#{wrap-subst\ 1301}# #{w\ 1818}#))
+ (let ((#{first\ 4547}#
+ (#{chi\ 3831}#
+ (car #{body\ 4543}#)
+ #{r\ 4544}#
+ #{w\ 4545}#
+ #{mod\ 4546}#)))
+ (cons #{first\ 4547}#
+ (#{dobody\ 4542}#
+ (cdr #{body\ 4543}#)
+ #{r\ 4544}#
+ #{w\ 4545}#
+ #{mod\ 4546}#)))))))
+ (#{dobody\ 4542}#
+ #{body\ 4537}#
+ #{r\ 4538}#
+ #{w\ 4539}#
+ #{mod\ 4541}#)))))
+ (#{source-wrap\ 3824}#
+ (lambda (#{x\ 4548}#
+ #{w\ 4549}#
+ #{s\ 4550}#
+ #{defmod\ 4551}#)
+ (#{wrap\ 3823}#
+ (#{decorate-source\ 3758}#
+ #{x\ 4548}#
+ #{s\ 4550}#)
+ #{w\ 4549}#
+ #{defmod\ 4551}#)))
+ (#{wrap\ 3823}#
+ (lambda (#{x\ 4552}# #{w\ 4553}# #{defmod\ 4554}#)
+ (if (if (null? (#{wrap-marks\ 3798}# #{w\ 4553}#))
+ (null? (#{wrap-subst\ 3799}# #{w\ 4553}#))
#f)
- #{x\ 1817}#
- (if (#{syntax-object?\ 1281}# #{x\ 1817}#)
- (#{make-syntax-object\ 1280}#
- (#{syntax-object-expression\ 1282}# #{x\ 1817}#)
- (#{join-wraps\ 1316}#
- #{w\ 1818}#
- (#{syntax-object-wrap\ 1283}# #{x\ 1817}#))
- (#{syntax-object-module\ 1284}# #{x\ 1817}#))
- (if (null? #{x\ 1817}#)
- #{x\ 1817}#
- (#{make-syntax-object\ 1280}#
- #{x\ 1817}#
- #{w\ 1818}#
- #{defmod\ 1819}#))))))
- (#{bound-id-member?\ 1324}#
- (lambda (#{x\ 1820}# #{list\ 1821}#)
- (if (not (null? #{list\ 1821}#))
- (let ((#{t\ 1822}#
- (#{bound-id=?\ 1321}#
- #{x\ 1820}#
- (car #{list\ 1821}#))))
- (if #{t\ 1822}#
- #{t\ 1822}#
- (#{bound-id-member?\ 1324}#
- #{x\ 1820}#
- (cdr #{list\ 1821}#))))
+ #{x\ 4552}#
+ (if (#{syntax-object?\ 3779}# #{x\ 4552}#)
+ (#{make-syntax-object\ 3778}#
+ (#{syntax-object-expression\ 3780}# #{x\ 4552}#)
+ (#{join-wraps\ 3814}#
+ #{w\ 4553}#
+ (#{syntax-object-wrap\ 3781}# #{x\ 4552}#))
+ (#{syntax-object-module\ 3782}# #{x\ 4552}#))
+ (if (null? #{x\ 4552}#)
+ #{x\ 4552}#
+ (#{make-syntax-object\ 3778}#
+ #{x\ 4552}#
+ #{w\ 4553}#
+ #{defmod\ 4554}#))))))
+ (#{bound-id-member?\ 3822}#
+ (lambda (#{x\ 4555}# #{list\ 4556}#)
+ (if (not (null? #{list\ 4556}#))
+ (let ((#{t\ 4557}#
+ (#{bound-id=?\ 3819}#
+ #{x\ 4555}#
+ (car #{list\ 4556}#))))
+ (if #{t\ 4557}#
+ #{t\ 4557}#
+ (#{bound-id-member?\ 3822}#
+ #{x\ 4555}#
+ (cdr #{list\ 4556}#))))
#f)))
- (#{distinct-bound-ids?\ 1323}#
- (lambda (#{ids\ 1823}#)
- (letrec ((#{distinct?\ 1824}#
- (lambda (#{ids\ 1825}#)
- (let ((#{t\ 1826}# (null? #{ids\ 1825}#)))
- (if #{t\ 1826}#
- #{t\ 1826}#
- (if (not (#{bound-id-member?\ 1324}#
- (car #{ids\ 1825}#)
- (cdr #{ids\ 1825}#)))
- (#{distinct?\ 1824}# (cdr #{ids\ 1825}#))
+ (#{distinct-bound-ids?\ 3821}#
+ (lambda (#{ids\ 4558}#)
+ (letrec ((#{distinct?\ 4559}#
+ (lambda (#{ids\ 4560}#)
+ (let ((#{t\ 4561}# (null? #{ids\ 4560}#)))
+ (if #{t\ 4561}#
+ #{t\ 4561}#
+ (if (not (#{bound-id-member?\ 3822}#
+ (car #{ids\ 4560}#)
+ (cdr #{ids\ 4560}#)))
+ (#{distinct?\ 4559}# (cdr #{ids\ 4560}#))
#f))))))
- (#{distinct?\ 1824}# #{ids\ 1823}#))))
- (#{valid-bound-ids?\ 1322}#
- (lambda (#{ids\ 1827}#)
- (if (letrec ((#{all-ids?\ 1828}#
- (lambda (#{ids\ 1829}#)
- (let ((#{t\ 1830}# (null? #{ids\ 1829}#)))
- (if #{t\ 1830}#
- #{t\ 1830}#
- (if (#{id?\ 1297}# (car #{ids\ 1829}#))
- (#{all-ids?\ 1828}# (cdr #{ids\ 1829}#))
+ (#{distinct?\ 4559}# #{ids\ 4558}#))))
+ (#{valid-bound-ids?\ 3820}#
+ (lambda (#{ids\ 4562}#)
+ (if (letrec ((#{all-ids?\ 4563}#
+ (lambda (#{ids\ 4564}#)
+ (let ((#{t\ 4565}# (null? #{ids\ 4564}#)))
+ (if #{t\ 4565}#
+ #{t\ 4565}#
+ (if (#{id?\ 3795}# (car #{ids\ 4564}#))
+ (#{all-ids?\ 4563}# (cdr #{ids\ 4564}#))
#f))))))
- (#{all-ids?\ 1828}# #{ids\ 1827}#))
- (#{distinct-bound-ids?\ 1323}# #{ids\ 1827}#)
+ (#{all-ids?\ 4563}# #{ids\ 4562}#))
+ (#{distinct-bound-ids?\ 3821}# #{ids\ 4562}#)
#f)))
- (#{bound-id=?\ 1321}#
- (lambda (#{i\ 1831}# #{j\ 1832}#)
- (if (if (#{syntax-object?\ 1281}# #{i\ 1831}#)
- (#{syntax-object?\ 1281}# #{j\ 1832}#)
+ (#{bound-id=?\ 3819}#
+ (lambda (#{i\ 4566}# #{j\ 4567}#)
+ (if (if (#{syntax-object?\ 3779}# #{i\ 4566}#)
+ (#{syntax-object?\ 3779}# #{j\ 4567}#)
#f)
- (if (eq? (#{syntax-object-expression\ 1282}# #{i\ 1831}#)
- (#{syntax-object-expression\ 1282}# #{j\ 1832}#))
- (#{same-marks?\ 1318}#
- (#{wrap-marks\ 1300}#
- (#{syntax-object-wrap\ 1283}# #{i\ 1831}#))
- (#{wrap-marks\ 1300}#
- (#{syntax-object-wrap\ 1283}# #{j\ 1832}#)))
+ (if (eq? (#{syntax-object-expression\ 3780}# #{i\ 4566}#)
+ (#{syntax-object-expression\ 3780}# #{j\ 4567}#))
+ (#{same-marks?\ 3816}#
+ (#{wrap-marks\ 3798}#
+ (#{syntax-object-wrap\ 3781}# #{i\ 4566}#))
+ (#{wrap-marks\ 3798}#
+ (#{syntax-object-wrap\ 3781}# #{j\ 4567}#)))
#f)
- (eq? #{i\ 1831}# #{j\ 1832}#))))
- (#{free-id=?\ 1320}#
- (lambda (#{i\ 1833}# #{j\ 1834}#)
- (if (eq? (let ((#{x\ 1835}# #{i\ 1833}#))
- (if (#{syntax-object?\ 1281}# #{x\ 1835}#)
- (#{syntax-object-expression\ 1282}# #{x\ 1835}#)
- #{x\ 1835}#))
- (let ((#{x\ 1836}# #{j\ 1834}#))
- (if (#{syntax-object?\ 1281}# #{x\ 1836}#)
- (#{syntax-object-expression\ 1282}# #{x\ 1836}#)
- #{x\ 1836}#)))
- (eq? (#{id-var-name\ 1319}# #{i\ 1833}# (quote (())))
- (#{id-var-name\ 1319}# #{j\ 1834}# (quote (()))))
+ (eq? #{i\ 4566}# #{j\ 4567}#))))
+ (#{free-id=?\ 3818}#
+ (lambda (#{i\ 4568}# #{j\ 4569}#)
+ (if (eq? (let ((#{x\ 4570}# #{i\ 4568}#))
+ (if (#{syntax-object?\ 3779}# #{x\ 4570}#)
+ (#{syntax-object-expression\ 3780}# #{x\ 4570}#)
+ #{x\ 4570}#))
+ (let ((#{x\ 4571}# #{j\ 4569}#))
+ (if (#{syntax-object?\ 3779}# #{x\ 4571}#)
+ (#{syntax-object-expression\ 3780}# #{x\ 4571}#)
+ #{x\ 4571}#)))
+ (eq? (#{id-var-name\ 3817}# #{i\ 4568}# (quote (())))
+ (#{id-var-name\ 3817}# #{j\ 4569}# (quote (()))))
#f)))
- (#{id-var-name\ 1319}#
- (lambda (#{id\ 1837}# #{w\ 1838}#)
- (letrec ((#{search-vector-rib\ 1841}#
- (lambda (#{sym\ 1847}#
- #{subst\ 1848}#
- #{marks\ 1849}#
- #{symnames\ 1850}#
- #{ribcage\ 1851}#)
- (let ((#{n\ 1852}#
- (vector-length #{symnames\ 1850}#)))
- (letrec ((#{f\ 1853}#
- (lambda (#{i\ 1854}#)
- (if (#{fx=\ 1256}#
- #{i\ 1854}#
- #{n\ 1852}#)
- (#{search\ 1839}#
- #{sym\ 1847}#
- (cdr #{subst\ 1848}#)
- #{marks\ 1849}#)
+ (#{id-var-name\ 3817}#
+ (lambda (#{id\ 4572}# #{w\ 4573}#)
+ (letrec ((#{search-vector-rib\ 4576}#
+ (lambda (#{sym\ 4582}#
+ #{subst\ 4583}#
+ #{marks\ 4584}#
+ #{symnames\ 4585}#
+ #{ribcage\ 4586}#)
+ (let ((#{n\ 4587}#
+ (vector-length #{symnames\ 4585}#)))
+ (letrec ((#{f\ 4588}#
+ (lambda (#{i\ 4589}#)
+ (if (#{fx=\ 3752}#
+ #{i\ 4589}#
+ #{n\ 4587}#)
+ (#{search\ 4574}#
+ #{sym\ 4582}#
+ (cdr #{subst\ 4583}#)
+ #{marks\ 4584}#)
(if (if (eq? (vector-ref
- #{symnames\ 1850}#
- #{i\ 1854}#)
- #{sym\ 1847}#)
- (#{same-marks?\ 1318}#
- #{marks\ 1849}#
+ #{symnames\ 4585}#
+ #{i\ 4589}#)
+ #{sym\ 4582}#)
+ (#{same-marks?\ 3816}#
+ #{marks\ 4584}#
(vector-ref
- (#{ribcage-marks\ 1307}#
- #{ribcage\ 1851}#)
- #{i\ 1854}#))
+ (#{ribcage-marks\ 3805}#
+ #{ribcage\ 4586}#)
+ #{i\ 4589}#))
#f)
(values
(vector-ref
- (#{ribcage-labels\ 1308}#
- #{ribcage\ 1851}#)
- #{i\ 1854}#)
- #{marks\ 1849}#)
- (#{f\ 1853}#
- (#{fx+\ 1254}#
- #{i\ 1854}#
+ (#{ribcage-labels\ 3806}#
+ #{ribcage\ 4586}#)
+ #{i\ 4589}#)
+ #{marks\ 4584}#)
+ (#{f\ 4588}#
+ (#{fx+\ 3750}#
+ #{i\ 4589}#
1)))))))
- (#{f\ 1853}# 0)))))
- (#{search-list-rib\ 1840}#
- (lambda (#{sym\ 1855}#
- #{subst\ 1856}#
- #{marks\ 1857}#
- #{symnames\ 1858}#
- #{ribcage\ 1859}#)
- (letrec ((#{f\ 1860}#
- (lambda (#{symnames\ 1861}# #{i\ 1862}#)
- (if (null? #{symnames\ 1861}#)
- (#{search\ 1839}#
- #{sym\ 1855}#
- (cdr #{subst\ 1856}#)
- #{marks\ 1857}#)
- (if (if (eq? (car #{symnames\ 1861}#)
- #{sym\ 1855}#)
- (#{same-marks?\ 1318}#
- #{marks\ 1857}#
+ (#{f\ 4588}# 0)))))
+ (#{search-list-rib\ 4575}#
+ (lambda (#{sym\ 4590}#
+ #{subst\ 4591}#
+ #{marks\ 4592}#
+ #{symnames\ 4593}#
+ #{ribcage\ 4594}#)
+ (letrec ((#{f\ 4595}#
+ (lambda (#{symnames\ 4596}# #{i\ 4597}#)
+ (if (null? #{symnames\ 4596}#)
+ (#{search\ 4574}#
+ #{sym\ 4590}#
+ (cdr #{subst\ 4591}#)
+ #{marks\ 4592}#)
+ (if (if (eq? (car #{symnames\ 4596}#)
+ #{sym\ 4590}#)
+ (#{same-marks?\ 3816}#
+ #{marks\ 4592}#
(list-ref
- (#{ribcage-marks\ 1307}#
- #{ribcage\ 1859}#)
- #{i\ 1862}#))
+ (#{ribcage-marks\ 3805}#
+ #{ribcage\ 4594}#)
+ #{i\ 4597}#))
#f)
(values
(list-ref
- (#{ribcage-labels\ 1308}#
- #{ribcage\ 1859}#)
- #{i\ 1862}#)
- #{marks\ 1857}#)
- (#{f\ 1860}#
- (cdr #{symnames\ 1861}#)
- (#{fx+\ 1254}#
- #{i\ 1862}#
+ (#{ribcage-labels\ 3806}#
+ #{ribcage\ 4594}#)
+ #{i\ 4597}#)
+ #{marks\ 4592}#)
+ (#{f\ 4595}#
+ (cdr #{symnames\ 4596}#)
+ (#{fx+\ 3750}#
+ #{i\ 4597}#
1)))))))
- (#{f\ 1860}# #{symnames\ 1858}# 0))))
- (#{search\ 1839}#
- (lambda (#{sym\ 1863}#
- #{subst\ 1864}#
- #{marks\ 1865}#)
- (if (null? #{subst\ 1864}#)
- (values #f #{marks\ 1865}#)
- (let ((#{fst\ 1866}# (car #{subst\ 1864}#)))
- (if (eq? #{fst\ 1866}# (quote shift))
- (#{search\ 1839}#
- #{sym\ 1863}#
- (cdr #{subst\ 1864}#)
- (cdr #{marks\ 1865}#))
- (let ((#{symnames\ 1867}#
- (#{ribcage-symnames\ 1306}#
- #{fst\ 1866}#)))
- (if (vector? #{symnames\ 1867}#)
- (#{search-vector-rib\ 1841}#
- #{sym\ 1863}#
- #{subst\ 1864}#
- #{marks\ 1865}#
- #{symnames\ 1867}#
- #{fst\ 1866}#)
- (#{search-list-rib\ 1840}#
- #{sym\ 1863}#
- #{subst\ 1864}#
- #{marks\ 1865}#
- #{symnames\ 1867}#
- #{fst\ 1866}#)))))))))
- (if (symbol? #{id\ 1837}#)
- (let ((#{t\ 1868}#
+ (#{f\ 4595}# #{symnames\ 4593}# 0))))
+ (#{search\ 4574}#
+ (lambda (#{sym\ 4598}#
+ #{subst\ 4599}#
+ #{marks\ 4600}#)
+ (if (null? #{subst\ 4599}#)
+ (values #f #{marks\ 4600}#)
+ (let ((#{fst\ 4601}# (car #{subst\ 4599}#)))
+ (if (eq? #{fst\ 4601}# (quote shift))
+ (#{search\ 4574}#
+ #{sym\ 4598}#
+ (cdr #{subst\ 4599}#)
+ (cdr #{marks\ 4600}#))
+ (let ((#{symnames\ 4602}#
+ (#{ribcage-symnames\ 3804}#
+ #{fst\ 4601}#)))
+ (if (vector? #{symnames\ 4602}#)
+ (#{search-vector-rib\ 4576}#
+ #{sym\ 4598}#
+ #{subst\ 4599}#
+ #{marks\ 4600}#
+ #{symnames\ 4602}#
+ #{fst\ 4601}#)
+ (#{search-list-rib\ 4575}#
+ #{sym\ 4598}#
+ #{subst\ 4599}#
+ #{marks\ 4600}#
+ #{symnames\ 4602}#
+ #{fst\ 4601}#)))))))))
+ (if (symbol? #{id\ 4572}#)
+ (let ((#{t\ 4603}#
(call-with-values
(lambda ()
- (#{search\ 1839}#
- #{id\ 1837}#
- (#{wrap-subst\ 1301}# #{w\ 1838}#)
- (#{wrap-marks\ 1300}# #{w\ 1838}#)))
- (lambda (#{x\ 1870}# . #{ignore\ 1869}#)
- #{x\ 1870}#))))
- (if #{t\ 1868}# #{t\ 1868}# #{id\ 1837}#))
- (if (#{syntax-object?\ 1281}# #{id\ 1837}#)
- (let ((#{id\ 1871}#
- (#{syntax-object-expression\ 1282}# #{id\ 1837}#))
- (#{w1\ 1872}#
- (#{syntax-object-wrap\ 1283}# #{id\ 1837}#)))
- (let ((#{marks\ 1873}#
- (#{join-marks\ 1317}#
- (#{wrap-marks\ 1300}# #{w\ 1838}#)
- (#{wrap-marks\ 1300}# #{w1\ 1872}#))))
+ (#{search\ 4574}#
+ #{id\ 4572}#
+ (#{wrap-subst\ 3799}# #{w\ 4573}#)
+ (#{wrap-marks\ 3798}# #{w\ 4573}#)))
+ (lambda (#{x\ 4604}# . #{ignore\ 4605}#)
+ #{x\ 4604}#))))
+ (if #{t\ 4603}# #{t\ 4603}# #{id\ 4572}#))
+ (if (#{syntax-object?\ 3779}# #{id\ 4572}#)
+ (let ((#{id\ 4606}#
+ (#{syntax-object-expression\ 3780}# #{id\ 4572}#))
+ (#{w1\ 4607}#
+ (#{syntax-object-wrap\ 3781}# #{id\ 4572}#)))
+ (let ((#{marks\ 4608}#
+ (#{join-marks\ 3815}#
+ (#{wrap-marks\ 3798}# #{w\ 4573}#)
+ (#{wrap-marks\ 3798}# #{w1\ 4607}#))))
(call-with-values
(lambda ()
- (#{search\ 1839}#
- #{id\ 1871}#
- (#{wrap-subst\ 1301}# #{w\ 1838}#)
- #{marks\ 1873}#))
- (lambda (#{new-id\ 1874}# #{marks\ 1875}#)
- (let ((#{t\ 1876}# #{new-id\ 1874}#))
- (if #{t\ 1876}#
- #{t\ 1876}#
- (let ((#{t\ 1877}#
+ (#{search\ 4574}#
+ #{id\ 4606}#
+ (#{wrap-subst\ 3799}# #{w\ 4573}#)
+ #{marks\ 4608}#))
+ (lambda (#{new-id\ 4609}# #{marks\ 4610}#)
+ (let ((#{t\ 4611}# #{new-id\ 4609}#))
+ (if #{t\ 4611}#
+ #{t\ 4611}#
+ (let ((#{t\ 4612}#
(call-with-values
(lambda ()
- (#{search\ 1839}#
- #{id\ 1871}#
- (#{wrap-subst\ 1301}#
- #{w1\ 1872}#)
- #{marks\ 1875}#))
- (lambda (#{x\ 1879}#
+ (#{search\ 4574}#
+ #{id\ 4606}#
+ (#{wrap-subst\ 3799}#
+ #{w1\ 4607}#)
+ #{marks\ 4610}#))
+ (lambda (#{x\ 4613}#
.
- #{ignore\ 1878}#)
- #{x\ 1879}#))))
- (if #{t\ 1877}#
- #{t\ 1877}#
- #{id\ 1871}#))))))))
+ #{ignore\ 4614}#)
+ #{x\ 4613}#))))
+ (if #{t\ 4612}#
+ #{t\ 4612}#
+ #{id\ 4606}#))))))))
(syntax-violation
'id-var-name
"invalid id"
- #{id\ 1837}#))))))
- (#{same-marks?\ 1318}#
- (lambda (#{x\ 1880}# #{y\ 1881}#)
- (let ((#{t\ 1882}# (eq? #{x\ 1880}# #{y\ 1881}#)))
- (if #{t\ 1882}#
- #{t\ 1882}#
- (if (not (null? #{x\ 1880}#))
- (if (not (null? #{y\ 1881}#))
- (if (eq? (car #{x\ 1880}#) (car #{y\ 1881}#))
- (#{same-marks?\ 1318}#
- (cdr #{x\ 1880}#)
- (cdr #{y\ 1881}#))
+ #{id\ 4572}#))))))
+ (#{same-marks?\ 3816}#
+ (lambda (#{x\ 4615}# #{y\ 4616}#)
+ (let ((#{t\ 4617}# (eq? #{x\ 4615}# #{y\ 4616}#)))
+ (if #{t\ 4617}#
+ #{t\ 4617}#
+ (if (not (null? #{x\ 4615}#))
+ (if (not (null? #{y\ 4616}#))
+ (if (eq? (car #{x\ 4615}#) (car #{y\ 4616}#))
+ (#{same-marks?\ 3816}#
+ (cdr #{x\ 4615}#)
+ (cdr #{y\ 4616}#))
#f)
#f)
#f)))))
- (#{join-marks\ 1317}#
- (lambda (#{m1\ 1883}# #{m2\ 1884}#)
- (#{smart-append\ 1315}#
- #{m1\ 1883}#
- #{m2\ 1884}#)))
- (#{join-wraps\ 1316}#
- (lambda (#{w1\ 1885}# #{w2\ 1886}#)
- (let ((#{m1\ 1887}#
- (#{wrap-marks\ 1300}# #{w1\ 1885}#))
- (#{s1\ 1888}#
- (#{wrap-subst\ 1301}# #{w1\ 1885}#)))
- (if (null? #{m1\ 1887}#)
- (if (null? #{s1\ 1888}#)
- #{w2\ 1886}#
- (#{make-wrap\ 1299}#
- (#{wrap-marks\ 1300}# #{w2\ 1886}#)
- (#{smart-append\ 1315}#
- #{s1\ 1888}#
- (#{wrap-subst\ 1301}# #{w2\ 1886}#))))
- (#{make-wrap\ 1299}#
- (#{smart-append\ 1315}#
- #{m1\ 1887}#
- (#{wrap-marks\ 1300}# #{w2\ 1886}#))
- (#{smart-append\ 1315}#
- #{s1\ 1888}#
- (#{wrap-subst\ 1301}# #{w2\ 1886}#)))))))
- (#{smart-append\ 1315}#
- (lambda (#{m1\ 1889}# #{m2\ 1890}#)
- (if (null? #{m2\ 1890}#)
- #{m1\ 1889}#
- (append #{m1\ 1889}# #{m2\ 1890}#))))
- (#{make-binding-wrap\ 1314}#
- (lambda (#{ids\ 1891}# #{labels\ 1892}# #{w\ 1893}#)
- (if (null? #{ids\ 1891}#)
- #{w\ 1893}#
- (#{make-wrap\ 1299}#
- (#{wrap-marks\ 1300}# #{w\ 1893}#)
- (cons (let ((#{labelvec\ 1894}#
- (list->vector #{labels\ 1892}#)))
- (let ((#{n\ 1895}#
- (vector-length #{labelvec\ 1894}#)))
- (let ((#{symnamevec\ 1896}#
- (make-vector #{n\ 1895}#))
- (#{marksvec\ 1897}#
- (make-vector #{n\ 1895}#)))
+ (#{join-marks\ 3815}#
+ (lambda (#{m1\ 4618}# #{m2\ 4619}#)
+ (#{smart-append\ 3813}#
+ #{m1\ 4618}#
+ #{m2\ 4619}#)))
+ (#{join-wraps\ 3814}#
+ (lambda (#{w1\ 4620}# #{w2\ 4621}#)
+ (let ((#{m1\ 4622}#
+ (#{wrap-marks\ 3798}# #{w1\ 4620}#))
+ (#{s1\ 4623}#
+ (#{wrap-subst\ 3799}# #{w1\ 4620}#)))
+ (if (null? #{m1\ 4622}#)
+ (if (null? #{s1\ 4623}#)
+ #{w2\ 4621}#
+ (#{make-wrap\ 3797}#
+ (#{wrap-marks\ 3798}# #{w2\ 4621}#)
+ (#{smart-append\ 3813}#
+ #{s1\ 4623}#
+ (#{wrap-subst\ 3799}# #{w2\ 4621}#))))
+ (#{make-wrap\ 3797}#
+ (#{smart-append\ 3813}#
+ #{m1\ 4622}#
+ (#{wrap-marks\ 3798}# #{w2\ 4621}#))
+ (#{smart-append\ 3813}#
+ #{s1\ 4623}#
+ (#{wrap-subst\ 3799}# #{w2\ 4621}#)))))))
+ (#{smart-append\ 3813}#
+ (lambda (#{m1\ 4624}# #{m2\ 4625}#)
+ (if (null? #{m2\ 4625}#)
+ #{m1\ 4624}#
+ (append #{m1\ 4624}# #{m2\ 4625}#))))
+ (#{make-binding-wrap\ 3812}#
+ (lambda (#{ids\ 4626}# #{labels\ 4627}# #{w\ 4628}#)
+ (if (null? #{ids\ 4626}#)
+ #{w\ 4628}#
+ (#{make-wrap\ 3797}#
+ (#{wrap-marks\ 3798}# #{w\ 4628}#)
+ (cons (let ((#{labelvec\ 4629}#
+ (list->vector #{labels\ 4627}#)))
+ (let ((#{n\ 4630}#
+ (vector-length #{labelvec\ 4629}#)))
+ (let ((#{symnamevec\ 4631}#
+ (make-vector #{n\ 4630}#))
+ (#{marksvec\ 4632}#
+ (make-vector #{n\ 4630}#)))
(begin
- (letrec ((#{f\ 1898}#
- (lambda (#{ids\ 1899}# #{i\ 1900}#)
- (if (not (null? #{ids\ 1899}#))
+ (letrec ((#{f\ 4633}#
+ (lambda (#{ids\ 4634}# #{i\ 4635}#)
+ (if (not (null? #{ids\ 4634}#))
(call-with-values
(lambda ()
- (#{id-sym-name&marks\ 1298}#
- (car #{ids\ 1899}#)
- #{w\ 1893}#))
- (lambda (#{symname\ 1901}#
- #{marks\ 1902}#)
+ (#{id-sym-name&marks\ 3796}#
+ (car #{ids\ 4634}#)
+ #{w\ 4628}#))
+ (lambda (#{symname\ 4636}#
+ #{marks\ 4637}#)
(begin
(vector-set!
- #{symnamevec\ 1896}#
- #{i\ 1900}#
- #{symname\ 1901}#)
+ #{symnamevec\ 4631}#
+ #{i\ 4635}#
+ #{symname\ 4636}#)
(vector-set!
- #{marksvec\ 1897}#
- #{i\ 1900}#
- #{marks\ 1902}#)
- (#{f\ 1898}#
- (cdr #{ids\ 1899}#)
- (#{fx+\ 1254}#
- #{i\ 1900}#
+ #{marksvec\ 4632}#
+ #{i\ 4635}#
+ #{marks\ 4637}#)
+ (#{f\ 4633}#
+ (cdr #{ids\ 4634}#)
+ (#{fx+\ 3750}#
+ #{i\ 4635}#
1)))))))))
- (#{f\ 1898}# #{ids\ 1891}# 0))
- (#{make-ribcage\ 1304}#
- #{symnamevec\ 1896}#
- #{marksvec\ 1897}#
- #{labelvec\ 1894}#)))))
- (#{wrap-subst\ 1301}# #{w\ 1893}#))))))
- (#{extend-ribcage!\ 1313}#
- (lambda (#{ribcage\ 1903}# #{id\ 1904}# #{label\ 1905}#)
+ (#{f\ 4633}# #{ids\ 4626}# 0))
+ (#{make-ribcage\ 3802}#
+ #{symnamevec\ 4631}#
+ #{marksvec\ 4632}#
+ #{labelvec\ 4629}#)))))
+ (#{wrap-subst\ 3799}# #{w\ 4628}#))))))
+ (#{extend-ribcage!\ 3811}#
+ (lambda (#{ribcage\ 4638}# #{id\ 4639}# #{label\ 4640}#)
(begin
- (#{set-ribcage-symnames!\ 1309}#
- #{ribcage\ 1903}#
- (cons (#{syntax-object-expression\ 1282}# #{id\ 1904}#)
- (#{ribcage-symnames\ 1306}# #{ribcage\ 1903}#)))
- (#{set-ribcage-marks!\ 1310}#
- #{ribcage\ 1903}#
- (cons (#{wrap-marks\ 1300}#
- (#{syntax-object-wrap\ 1283}# #{id\ 1904}#))
- (#{ribcage-marks\ 1307}# #{ribcage\ 1903}#)))
- (#{set-ribcage-labels!\ 1311}#
- #{ribcage\ 1903}#
- (cons #{label\ 1905}#
- (#{ribcage-labels\ 1308}# #{ribcage\ 1903}#))))))
- (#{anti-mark\ 1312}#
- (lambda (#{w\ 1906}#)
- (#{make-wrap\ 1299}#
- (cons #f (#{wrap-marks\ 1300}# #{w\ 1906}#))
+ (#{set-ribcage-symnames!\ 3807}#
+ #{ribcage\ 4638}#
+ (cons (#{syntax-object-expression\ 3780}# #{id\ 4639}#)
+ (#{ribcage-symnames\ 3804}# #{ribcage\ 4638}#)))
+ (#{set-ribcage-marks!\ 3808}#
+ #{ribcage\ 4638}#
+ (cons (#{wrap-marks\ 3798}#
+ (#{syntax-object-wrap\ 3781}# #{id\ 4639}#))
+ (#{ribcage-marks\ 3805}# #{ribcage\ 4638}#)))
+ (#{set-ribcage-labels!\ 3809}#
+ #{ribcage\ 4638}#
+ (cons #{label\ 4640}#
+ (#{ribcage-labels\ 3806}# #{ribcage\ 4638}#))))))
+ (#{anti-mark\ 3810}#
+ (lambda (#{w\ 4641}#)
+ (#{make-wrap\ 3797}#
+ (cons #f (#{wrap-marks\ 3798}# #{w\ 4641}#))
(cons 'shift
- (#{wrap-subst\ 1301}# #{w\ 1906}#)))))
- (#{set-ribcage-labels!\ 1311}#
- (lambda (#{x\ 1907}# #{update\ 1908}#)
- (vector-set! #{x\ 1907}# 3 #{update\ 1908}#)))
- (#{set-ribcage-marks!\ 1310}#
- (lambda (#{x\ 1909}# #{update\ 1910}#)
- (vector-set! #{x\ 1909}# 2 #{update\ 1910}#)))
- (#{set-ribcage-symnames!\ 1309}#
- (lambda (#{x\ 1911}# #{update\ 1912}#)
- (vector-set! #{x\ 1911}# 1 #{update\ 1912}#)))
- (#{ribcage-labels\ 1308}#
- (lambda (#{x\ 1913}#) (vector-ref #{x\ 1913}# 3)))
- (#{ribcage-marks\ 1307}#
- (lambda (#{x\ 1914}#) (vector-ref #{x\ 1914}# 2)))
- (#{ribcage-symnames\ 1306}#
- (lambda (#{x\ 1915}#) (vector-ref #{x\ 1915}# 1)))
- (#{ribcage?\ 1305}#
- (lambda (#{x\ 1916}#)
- (if (vector? #{x\ 1916}#)
- (if (= (vector-length #{x\ 1916}#) 4)
- (eq? (vector-ref #{x\ 1916}# 0) (quote ribcage))
+ (#{wrap-subst\ 3799}# #{w\ 4641}#)))))
+ (#{set-ribcage-labels!\ 3809}#
+ (lambda (#{x\ 4642}# #{update\ 4643}#)
+ (vector-set! #{x\ 4642}# 3 #{update\ 4643}#)))
+ (#{set-ribcage-marks!\ 3808}#
+ (lambda (#{x\ 4644}# #{update\ 4645}#)
+ (vector-set! #{x\ 4644}# 2 #{update\ 4645}#)))
+ (#{set-ribcage-symnames!\ 3807}#
+ (lambda (#{x\ 4646}# #{update\ 4647}#)
+ (vector-set! #{x\ 4646}# 1 #{update\ 4647}#)))
+ (#{ribcage-labels\ 3806}#
+ (lambda (#{x\ 4648}#) (vector-ref #{x\ 4648}# 3)))
+ (#{ribcage-marks\ 3805}#
+ (lambda (#{x\ 4649}#) (vector-ref #{x\ 4649}# 2)))
+ (#{ribcage-symnames\ 3804}#
+ (lambda (#{x\ 4650}#) (vector-ref #{x\ 4650}# 1)))
+ (#{ribcage?\ 3803}#
+ (lambda (#{x\ 4651}#)
+ (if (vector? #{x\ 4651}#)
+ (if (= (vector-length #{x\ 4651}#) 4)
+ (eq? (vector-ref #{x\ 4651}# 0) (quote ribcage))
#f)
#f)))
- (#{make-ribcage\ 1304}#
- (lambda (#{symnames\ 1917}#
- #{marks\ 1918}#
- #{labels\ 1919}#)
+ (#{make-ribcage\ 3802}#
+ (lambda (#{symnames\ 4652}#
+ #{marks\ 4653}#
+ #{labels\ 4654}#)
(vector
'ribcage
- #{symnames\ 1917}#
- #{marks\ 1918}#
- #{labels\ 1919}#)))
- (#{gen-labels\ 1303}#
- (lambda (#{ls\ 1920}#)
- (if (null? #{ls\ 1920}#)
+ #{symnames\ 4652}#
+ #{marks\ 4653}#
+ #{labels\ 4654}#)))
+ (#{gen-labels\ 3801}#
+ (lambda (#{ls\ 4655}#)
+ (if (null? #{ls\ 4655}#)
'()
- (cons (#{gen-label\ 1302}#)
- (#{gen-labels\ 1303}# (cdr #{ls\ 1920}#))))))
- (#{gen-label\ 1302}# (lambda () (string #\i)))
- (#{wrap-subst\ 1301}# cdr)
- (#{wrap-marks\ 1300}# car)
- (#{make-wrap\ 1299}# cons)
- (#{id-sym-name&marks\ 1298}#
- (lambda (#{x\ 1921}# #{w\ 1922}#)
- (if (#{syntax-object?\ 1281}# #{x\ 1921}#)
+ (cons (#{gen-label\ 3800}#)
+ (#{gen-labels\ 3801}# (cdr #{ls\ 4655}#))))))
+ (#{gen-label\ 3800}# (lambda () (string #\i)))
+ (#{wrap-subst\ 3799}# cdr)
+ (#{wrap-marks\ 3798}# car)
+ (#{make-wrap\ 3797}# cons)
+ (#{id-sym-name&marks\ 3796}#
+ (lambda (#{x\ 4656}# #{w\ 4657}#)
+ (if (#{syntax-object?\ 3779}# #{x\ 4656}#)
(values
- (#{syntax-object-expression\ 1282}# #{x\ 1921}#)
- (#{join-marks\ 1317}#
- (#{wrap-marks\ 1300}# #{w\ 1922}#)
- (#{wrap-marks\ 1300}#
- (#{syntax-object-wrap\ 1283}# #{x\ 1921}#))))
+ (#{syntax-object-expression\ 3780}# #{x\ 4656}#)
+ (#{join-marks\ 3815}#
+ (#{wrap-marks\ 3798}# #{w\ 4657}#)
+ (#{wrap-marks\ 3798}#
+ (#{syntax-object-wrap\ 3781}# #{x\ 4656}#))))
(values
- #{x\ 1921}#
- (#{wrap-marks\ 1300}# #{w\ 1922}#)))))
- (#{id?\ 1297}#
- (lambda (#{x\ 1923}#)
- (if (symbol? #{x\ 1923}#)
+ #{x\ 4656}#
+ (#{wrap-marks\ 3798}# #{w\ 4657}#)))))
+ (#{id?\ 3795}#
+ (lambda (#{x\ 4658}#)
+ (if (symbol? #{x\ 4658}#)
#t
- (if (#{syntax-object?\ 1281}# #{x\ 1923}#)
+ (if (#{syntax-object?\ 3779}# #{x\ 4658}#)
(symbol?
- (#{syntax-object-expression\ 1282}# #{x\ 1923}#))
+ (#{syntax-object-expression\ 3780}# #{x\ 4658}#))
#f))))
- (#{nonsymbol-id?\ 1296}#
- (lambda (#{x\ 1924}#)
- (if (#{syntax-object?\ 1281}# #{x\ 1924}#)
+ (#{nonsymbol-id?\ 3794}#
+ (lambda (#{x\ 4659}#)
+ (if (#{syntax-object?\ 3779}# #{x\ 4659}#)
(symbol?
- (#{syntax-object-expression\ 1282}# #{x\ 1924}#))
+ (#{syntax-object-expression\ 3780}# #{x\ 4659}#))
#f)))
- (#{global-extend\ 1295}#
- (lambda (#{type\ 1925}# #{sym\ 1926}# #{val\ 1927}#)
- (#{put-global-definition-hook\ 1260}#
- #{sym\ 1926}#
- #{type\ 1925}#
- #{val\ 1927}#)))
- (#{lookup\ 1294}#
- (lambda (#{x\ 1928}# #{r\ 1929}# #{mod\ 1930}#)
- (let ((#{t\ 1931}# (assq #{x\ 1928}# #{r\ 1929}#)))
- (if #{t\ 1931}#
- (cdr #{t\ 1931}#)
- (if (symbol? #{x\ 1928}#)
- (let ((#{t\ 1932}#
- (#{get-global-definition-hook\ 1261}#
- #{x\ 1928}#
- #{mod\ 1930}#)))
- (if #{t\ 1932}# #{t\ 1932}# (quote (global))))
+ (#{global-extend\ 3793}#
+ (lambda (#{type\ 4660}# #{sym\ 4661}# #{val\ 4662}#)
+ (#{put-global-definition-hook\ 3756}#
+ #{sym\ 4661}#
+ #{type\ 4660}#
+ #{val\ 4662}#)))
+ (#{lookup\ 3792}#
+ (lambda (#{x\ 4663}# #{r\ 4664}# #{mod\ 4665}#)
+ (let ((#{t\ 4666}# (assq #{x\ 4663}# #{r\ 4664}#)))
+ (if #{t\ 4666}#
+ (cdr #{t\ 4666}#)
+ (if (symbol? #{x\ 4663}#)
+ (let ((#{t\ 4667}#
+ (#{get-global-definition-hook\ 3757}#
+ #{x\ 4663}#
+ #{mod\ 4665}#)))
+ (if #{t\ 4667}# #{t\ 4667}# (quote (global))))
'(displaced-lexical))))))
- (#{macros-only-env\ 1293}#
- (lambda (#{r\ 1933}#)
- (if (null? #{r\ 1933}#)
+ (#{macros-only-env\ 3791}#
+ (lambda (#{r\ 4668}#)
+ (if (null? #{r\ 4668}#)
'()
- (let ((#{a\ 1934}# (car #{r\ 1933}#)))
- (if (eq? (cadr #{a\ 1934}#) (quote macro))
- (cons #{a\ 1934}#
- (#{macros-only-env\ 1293}# (cdr #{r\ 1933}#)))
- (#{macros-only-env\ 1293}# (cdr #{r\ 1933}#)))))))
- (#{extend-var-env\ 1292}#
- (lambda (#{labels\ 1935}# #{vars\ 1936}# #{r\ 1937}#)
- (if (null? #{labels\ 1935}#)
- #{r\ 1937}#
- (#{extend-var-env\ 1292}#
- (cdr #{labels\ 1935}#)
- (cdr #{vars\ 1936}#)
- (cons (cons (car #{labels\ 1935}#)
- (cons (quote lexical) (car #{vars\ 1936}#)))
- #{r\ 1937}#)))))
- (#{extend-env\ 1291}#
- (lambda (#{labels\ 1938}# #{bindings\ 1939}# #{r\ 1940}#)
- (if (null? #{labels\ 1938}#)
- #{r\ 1940}#
- (#{extend-env\ 1291}#
- (cdr #{labels\ 1938}#)
- (cdr #{bindings\ 1939}#)
- (cons (cons (car #{labels\ 1938}#)
- (car #{bindings\ 1939}#))
- #{r\ 1940}#)))))
- (#{binding-value\ 1290}# cdr)
- (#{binding-type\ 1289}# car)
- (#{source-annotation\ 1288}#
- (lambda (#{x\ 1941}#)
- (if (#{syntax-object?\ 1281}# #{x\ 1941}#)
- (#{source-annotation\ 1288}#
- (#{syntax-object-expression\ 1282}# #{x\ 1941}#))
- (if (pair? #{x\ 1941}#)
- (let ((#{props\ 1942}# (source-properties #{x\ 1941}#)))
- (if (pair? #{props\ 1942}#) #{props\ 1942}# #f))
+ (let ((#{a\ 4669}# (car #{r\ 4668}#)))
+ (if (eq? (cadr #{a\ 4669}#) (quote macro))
+ (cons #{a\ 4669}#
+ (#{macros-only-env\ 3791}# (cdr #{r\ 4668}#)))
+ (#{macros-only-env\ 3791}# (cdr #{r\ 4668}#)))))))
+ (#{extend-var-env\ 3790}#
+ (lambda (#{labels\ 4670}# #{vars\ 4671}# #{r\ 4672}#)
+ (if (null? #{labels\ 4670}#)
+ #{r\ 4672}#
+ (#{extend-var-env\ 3790}#
+ (cdr #{labels\ 4670}#)
+ (cdr #{vars\ 4671}#)
+ (cons (cons (car #{labels\ 4670}#)
+ (cons (quote lexical) (car #{vars\ 4671}#)))
+ #{r\ 4672}#)))))
+ (#{extend-env\ 3789}#
+ (lambda (#{labels\ 4673}# #{bindings\ 4674}# #{r\ 4675}#)
+ (if (null? #{labels\ 4673}#)
+ #{r\ 4675}#
+ (#{extend-env\ 3789}#
+ (cdr #{labels\ 4673}#)
+ (cdr #{bindings\ 4674}#)
+ (cons (cons (car #{labels\ 4673}#)
+ (car #{bindings\ 4674}#))
+ #{r\ 4675}#)))))
+ (#{binding-value\ 3788}# cdr)
+ (#{binding-type\ 3787}# car)
+ (#{source-annotation\ 3786}#
+ (lambda (#{x\ 4676}#)
+ (if (#{syntax-object?\ 3779}# #{x\ 4676}#)
+ (#{source-annotation\ 3786}#
+ (#{syntax-object-expression\ 3780}# #{x\ 4676}#))
+ (if (pair? #{x\ 4676}#)
+ (let ((#{props\ 4677}# (source-properties #{x\ 4676}#)))
+ (if (pair? #{props\ 4677}#) #{props\ 4677}# #f))
#f))))
- (#{set-syntax-object-module!\ 1287}#
- (lambda (#{x\ 1943}# #{update\ 1944}#)
- (vector-set! #{x\ 1943}# 3 #{update\ 1944}#)))
- (#{set-syntax-object-wrap!\ 1286}#
- (lambda (#{x\ 1945}# #{update\ 1946}#)
- (vector-set! #{x\ 1945}# 2 #{update\ 1946}#)))
- (#{set-syntax-object-expression!\ 1285}#
- (lambda (#{x\ 1947}# #{update\ 1948}#)
- (vector-set! #{x\ 1947}# 1 #{update\ 1948}#)))
- (#{syntax-object-module\ 1284}#
- (lambda (#{x\ 1949}#) (vector-ref #{x\ 1949}# 3)))
- (#{syntax-object-wrap\ 1283}#
- (lambda (#{x\ 1950}#) (vector-ref #{x\ 1950}# 2)))
- (#{syntax-object-expression\ 1282}#
- (lambda (#{x\ 1951}#) (vector-ref #{x\ 1951}# 1)))
- (#{syntax-object?\ 1281}#
- (lambda (#{x\ 1952}#)
- (if (vector? #{x\ 1952}#)
- (if (= (vector-length #{x\ 1952}#) 4)
- (eq? (vector-ref #{x\ 1952}# 0)
+ (#{set-syntax-object-module!\ 3785}#
+ (lambda (#{x\ 4678}# #{update\ 4679}#)
+ (vector-set! #{x\ 4678}# 3 #{update\ 4679}#)))
+ (#{set-syntax-object-wrap!\ 3784}#
+ (lambda (#{x\ 4680}# #{update\ 4681}#)
+ (vector-set! #{x\ 4680}# 2 #{update\ 4681}#)))
+ (#{set-syntax-object-expression!\ 3783}#
+ (lambda (#{x\ 4682}# #{update\ 4683}#)
+ (vector-set! #{x\ 4682}# 1 #{update\ 4683}#)))
+ (#{syntax-object-module\ 3782}#
+ (lambda (#{x\ 4684}#) (vector-ref #{x\ 4684}# 3)))
+ (#{syntax-object-wrap\ 3781}#
+ (lambda (#{x\ 4685}#) (vector-ref #{x\ 4685}# 2)))
+ (#{syntax-object-expression\ 3780}#
+ (lambda (#{x\ 4686}#) (vector-ref #{x\ 4686}# 1)))
+ (#{syntax-object?\ 3779}#
+ (lambda (#{x\ 4687}#)
+ (if (vector? #{x\ 4687}#)
+ (if (= (vector-length #{x\ 4687}#) 4)
+ (eq? (vector-ref #{x\ 4687}# 0)
'syntax-object)
#f)
#f)))
- (#{make-syntax-object\ 1280}#
- (lambda (#{expression\ 1953}#
- #{wrap\ 1954}#
- #{module\ 1955}#)
+ (#{make-syntax-object\ 3778}#
+ (lambda (#{expression\ 4688}#
+ #{wrap\ 4689}#
+ #{module\ 4690}#)
(vector
'syntax-object
- #{expression\ 1953}#
- #{wrap\ 1954}#
- #{module\ 1955}#)))
- (#{build-letrec\ 1279}#
- (lambda (#{src\ 1956}#
- #{ids\ 1957}#
- #{vars\ 1958}#
- #{val-exps\ 1959}#
- #{body-exp\ 1960}#)
- (if (null? #{vars\ 1958}#)
- #{body-exp\ 1960}#
- (let ((#{atom-key\ 1961}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1961}# (quote (c)))
+ #{expression\ 4688}#
+ #{wrap\ 4689}#
+ #{module\ 4690}#)))
+ (#{build-letrec\ 3777}#
+ (lambda (#{src\ 4691}#
+ #{ids\ 4692}#
+ #{vars\ 4693}#
+ #{val-exps\ 4694}#
+ #{body-exp\ 4695}#)
+ (if (null? #{vars\ 4693}#)
+ #{body-exp\ 4695}#
+ (let ((#{atom-key\ 4696}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4696}# (quote (c)))
(begin
(for-each
- #{maybe-name-value!\ 1271}#
- #{ids\ 1957}#
- #{val-exps\ 1959}#)
+ #{maybe-name-value!\ 3767}#
+ #{ids\ 4692}#
+ #{val-exps\ 4694}#)
((@ (language tree-il) make-letrec)
- #{src\ 1956}#
- #{ids\ 1957}#
- #{vars\ 1958}#
- #{val-exps\ 1959}#
- #{body-exp\ 1960}#))
- (#{decorate-source\ 1262}#
+ #{src\ 4691}#
+ #{ids\ 4692}#
+ #{vars\ 4693}#
+ #{val-exps\ 4694}#
+ #{body-exp\ 4695}#))
+ (#{decorate-source\ 3758}#
(list 'letrec
- (map list #{vars\ 1958}# #{val-exps\ 1959}#)
- #{body-exp\ 1960}#)
- #{src\ 1956}#))))))
- (#{build-named-let\ 1278}#
- (lambda (#{src\ 1962}#
- #{ids\ 1963}#
- #{vars\ 1964}#
- #{val-exps\ 1965}#
- #{body-exp\ 1966}#)
- (let ((#{f\ 1967}# (car #{vars\ 1964}#))
- (#{f-name\ 1968}# (car #{ids\ 1963}#))
- (#{vars\ 1969}# (cdr #{vars\ 1964}#))
- (#{ids\ 1970}# (cdr #{ids\ 1963}#)))
- (let ((#{atom-key\ 1971}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1971}# (quote (c)))
- (let ((#{proc\ 1972}#
- (#{build-lambda\ 1273}#
- #{src\ 1962}#
- #{ids\ 1970}#
- #{vars\ 1969}#
+ (map list #{vars\ 4693}# #{val-exps\ 4694}#)
+ #{body-exp\ 4695}#)
+ #{src\ 4691}#))))))
+ (#{build-named-let\ 3776}#
+ (lambda (#{src\ 4697}#
+ #{ids\ 4698}#
+ #{vars\ 4699}#
+ #{val-exps\ 4700}#
+ #{body-exp\ 4701}#)
+ (let ((#{f\ 4702}# (car #{vars\ 4699}#))
+ (#{f-name\ 4703}# (car #{ids\ 4698}#))
+ (#{vars\ 4704}# (cdr #{vars\ 4699}#))
+ (#{ids\ 4705}# (cdr #{ids\ 4698}#)))
+ (let ((#{atom-key\ 4706}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4706}# (quote (c)))
+ (let ((#{proc\ 4707}#
+ (#{build-simple-lambda\ 3769}#
+ #{src\ 4697}#
+ #{ids\ 4705}#
#f
- #{body-exp\ 1966}#)))
+ #{vars\ 4704}#
+ #f
+ #{body-exp\ 4701}#)))
(begin
- (#{maybe-name-value!\ 1271}#
- #{f-name\ 1968}#
- #{proc\ 1972}#)
+ (#{maybe-name-value!\ 3767}#
+ #{f-name\ 4703}#
+ #{proc\ 4707}#)
(for-each
- #{maybe-name-value!\ 1271}#
- #{ids\ 1970}#
- #{val-exps\ 1965}#)
+ #{maybe-name-value!\ 3767}#
+ #{ids\ 4705}#
+ #{val-exps\ 4700}#)
((@ (language tree-il) make-letrec)
- #{src\ 1962}#
- (list #{f-name\ 1968}#)
- (list #{f\ 1967}#)
- (list #{proc\ 1972}#)
- (#{build-application\ 1264}#
- #{src\ 1962}#
- (#{build-lexical-reference\ 1266}#
+ #{src\ 4697}#
+ (list #{f-name\ 4703}#)
+ (list #{f\ 4702}#)
+ (list #{proc\ 4707}#)
+ (#{build-application\ 3760}#
+ #{src\ 4697}#
+ (#{build-lexical-reference\ 3762}#
'fun
- #{src\ 1962}#
- #{f-name\ 1968}#
- #{f\ 1967}#)
- #{val-exps\ 1965}#))))
- (#{decorate-source\ 1262}#
- (list 'let
- #{f\ 1967}#
- (map list #{vars\ 1969}# #{val-exps\ 1965}#)
- #{body-exp\ 1966}#)
- #{src\ 1962}#))))))
- (#{build-let\ 1277}#
- (lambda (#{src\ 1973}#
- #{ids\ 1974}#
- #{vars\ 1975}#
- #{val-exps\ 1976}#
- #{body-exp\ 1977}#)
- (if (null? #{vars\ 1975}#)
- #{body-exp\ 1977}#
- (let ((#{atom-key\ 1978}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1978}# (quote (c)))
+ #{src\ 4697}#
+ #{f-name\ 4703}#
+ #{f\ 4702}#)
+ #{val-exps\ 4700}#))))
+ (#{decorate-source\ 3758}#
+ (list 'letrec
+ (list (list #{f\ 4702}#
+ (list 'lambda
+ #{vars\ 4704}#
+ #{body-exp\ 4701}#)))
+ (cons #{f\ 4702}# #{val-exps\ 4700}#))
+ #{src\ 4697}#))))))
+ (#{build-let\ 3775}#
+ (lambda (#{src\ 4708}#
+ #{ids\ 4709}#
+ #{vars\ 4710}#
+ #{val-exps\ 4711}#
+ #{body-exp\ 4712}#)
+ (if (null? #{vars\ 4710}#)
+ #{body-exp\ 4712}#
+ (let ((#{atom-key\ 4713}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4713}# (quote (c)))
(begin
(for-each
- #{maybe-name-value!\ 1271}#
- #{ids\ 1974}#
- #{val-exps\ 1976}#)
+ #{maybe-name-value!\ 3767}#
+ #{ids\ 4709}#
+ #{val-exps\ 4711}#)
((@ (language tree-il) make-let)
- #{src\ 1973}#
- #{ids\ 1974}#
- #{vars\ 1975}#
- #{val-exps\ 1976}#
- #{body-exp\ 1977}#))
- (#{decorate-source\ 1262}#
+ #{src\ 4708}#
+ #{ids\ 4709}#
+ #{vars\ 4710}#
+ #{val-exps\ 4711}#
+ #{body-exp\ 4712}#))
+ (#{decorate-source\ 3758}#
(list 'let
- (map list #{vars\ 1975}# #{val-exps\ 1976}#)
- #{body-exp\ 1977}#)
- #{src\ 1973}#))))))
- (#{build-sequence\ 1276}#
- (lambda (#{src\ 1979}# #{exps\ 1980}#)
- (if (null? (cdr #{exps\ 1980}#))
- (car #{exps\ 1980}#)
- (let ((#{atom-key\ 1981}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1981}# (quote (c)))
+ (map list #{vars\ 4710}# #{val-exps\ 4711}#)
+ #{body-exp\ 4712}#)
+ #{src\ 4708}#))))))
+ (#{build-sequence\ 3774}#
+ (lambda (#{src\ 4714}# #{exps\ 4715}#)
+ (if (null? (cdr #{exps\ 4715}#))
+ (car #{exps\ 4715}#)
+ (let ((#{atom-key\ 4716}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4716}# (quote (c)))
((@ (language tree-il) make-sequence)
- #{src\ 1979}#
- #{exps\ 1980}#)
- (#{decorate-source\ 1262}#
- (cons (quote begin) #{exps\ 1980}#)
- #{src\ 1979}#))))))
- (#{build-data\ 1275}#
- (lambda (#{src\ 1982}# #{exp\ 1983}#)
- (let ((#{atom-key\ 1984}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1984}# (quote (c)))
+ #{src\ 4714}#
+ #{exps\ 4715}#)
+ (#{decorate-source\ 3758}#
+ (cons (quote begin) #{exps\ 4715}#)
+ #{src\ 4714}#))))))
+ (#{build-data\ 3773}#
+ (lambda (#{src\ 4717}# #{exp\ 4718}#)
+ (let ((#{atom-key\ 4719}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4719}# (quote (c)))
((@ (language tree-il) make-const)
- #{src\ 1982}#
- #{exp\ 1983}#)
- (#{decorate-source\ 1262}#
- (if (if (self-evaluating? #{exp\ 1983}#)
- (not (vector? #{exp\ 1983}#))
+ #{src\ 4717}#
+ #{exp\ 4718}#)
+ (#{decorate-source\ 3758}#
+ (if (if (self-evaluating? #{exp\ 4718}#)
+ (not (vector? #{exp\ 4718}#))
#f)
- #{exp\ 1983}#
- (list (quote quote) #{exp\ 1983}#))
- #{src\ 1982}#)))))
- (#{build-primref\ 1274}#
- (lambda (#{src\ 1985}# #{name\ 1986}#)
+ #{exp\ 4718}#
+ (list (quote quote) #{exp\ 4718}#))
+ #{src\ 4717}#)))))
+ (#{build-primref\ 3772}#
+ (lambda (#{src\ 4720}# #{name\ 4721}#)
(if (equal?
(module-name (current-module))
'(guile))
- (let ((#{atom-key\ 1987}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1987}# (quote (c)))
+ (let ((#{atom-key\ 4722}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4722}# (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- #{src\ 1985}#
- #{name\ 1986}#)
- (#{decorate-source\ 1262}#
- #{name\ 1986}#
- #{src\ 1985}#)))
- (let ((#{atom-key\ 1988}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1988}# (quote (c)))
+ #{src\ 4720}#
+ #{name\ 4721}#)
+ (#{decorate-source\ 3758}#
+ #{name\ 4721}#
+ #{src\ 4720}#)))
+ (let ((#{atom-key\ 4723}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4723}# (quote (c)))
((@ (language tree-il) make-module-ref)
- #{src\ 1985}#
+ #{src\ 4720}#
'(guile)
- #{name\ 1986}#
+ #{name\ 4721}#
#f)
- (#{decorate-source\ 1262}#
- (list (quote @@) (quote (guile)) #{name\ 1986}#)
- #{src\ 1985}#))))))
- (#{build-lambda\ 1273}#
- (lambda (#{src\ 1989}#
- #{ids\ 1990}#
- #{vars\ 1991}#
- #{docstring\ 1992}#
- #{exp\ 1993}#)
- (let ((#{atom-key\ 1994}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1994}# (quote (c)))
+ (#{decorate-source\ 3758}#
+ (list (quote @@) (quote (guile)) #{name\ 4721}#)
+ #{src\ 4720}#))))))
+ (#{build-lambda-case\ 3771}#
+ (lambda (#{src\ 4724}#
+ #{req\ 4725}#
+ #{opt\ 4726}#
+ #{rest\ 4727}#
+ #{kw\ 4728}#
+ #{inits\ 4729}#
+ #{vars\ 4730}#
+ #{body\ 4731}#
+ #{else-case\ 4732}#)
+ (let ((#{atom-key\ 4733}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4733}# (quote (c)))
+ ((@ (language tree-il) make-lambda-case)
+ #{src\ 4724}#
+ #{req\ 4725}#
+ #{opt\ 4726}#
+ #{rest\ 4727}#
+ #{kw\ 4728}#
+ #{inits\ 4729}#
+ #{vars\ 4730}#
+ #{body\ 4731}#
+ #{else-case\ 4732}#)
+ (let ((#{nreq\ 4734}# (length #{req\ 4725}#)))
+ (let ((#{nopt\ 4735}#
+ (if #{opt\ 4726}# (length #{opt\ 4726}#) 0)))
+ (let ((#{rest-idx\ 4736}#
+ (if #{rest\ 4727}#
+ (+ #{nreq\ 4734}# #{nopt\ 4735}#)
+ #f)))
+ (let ((#{allow-other-keys?\ 4737}#
+ (if #{kw\ 4728}# (car #{kw\ 4728}#) #f)))
+ (let ((#{kw-indices\ 4738}#
+ (map (lambda (#{x\ 4739}#)
+ (cons (car #{x\ 4739}#)
+ (list-index
+ #{vars\ 4730}#
+ (caddr #{x\ 4739}#))))
+ (if #{kw\ 4728}#
+ (cdr #{kw\ 4728}#)
+ '()))))
+ (let ((#{nargs\ 4740}#
+ (apply max
+ (+ #{nreq\ 4734}#
+ #{nopt\ 4735}#
+ (if #{rest\ 4727}# 1 0))
+ (map 1+
+ (map cdr
+ #{kw-indices\ 4738}#)))))
+ (begin
+ (let ((#{t\ 4741}#
+ (= #{nargs\ 4740}#
+ (length #{vars\ 4730}#)
+ (+ #{nreq\ 4734}#
+ (length #{inits\ 4729}#)
+ (if #{rest\ 4727}# 1 0)))))
+ (if #{t\ 4741}#
+ #{t\ 4741}#
+ (error "something went wrong"
+ #{req\ 4725}#
+ #{opt\ 4726}#
+ #{rest\ 4727}#
+ #{kw\ 4728}#
+ #{inits\ 4729}#
+ #{vars\ 4730}#
+ #{nreq\ 4734}#
+ #{nopt\ 4735}#
+ #{kw-indices\ 4738}#
+ #{nargs\ 4740}#)))
+ (#{decorate-source\ 3758}#
+ (cons (list (cons '(@@ (ice-9 optargs)
+ parse-lambda-case)
+ (cons (list 'quote
+ (list #{nreq\ 4734}#
+ #{nopt\ 4735}#
+ #{rest-idx\ 4736}#
+ #{nargs\ 4740}#
+ #{allow-other-keys?\ 4737}#
+ #{kw-indices\ 4738}#))
+ (cons (cons 'list
+ (map (lambda (#{i\ 4742}#)
+ (list 'lambda
+ #{vars\ 4730}#
+ #{i\ 4742}#))
+ #{inits\ 4729}#))
+ '(%%args))))
+ '=>
+ (list 'lambda
+ '(%%%args . _)
+ (cons 'apply
+ (cons (list 'lambda
+ #{vars\ 4730}#
+ #{body\ 4731}#)
+ '(%%%args)))))
+ (let ((#{t\ 4743}#
+ #{else-case\ 4732}#))
+ (if #{t\ 4743}#
+ #{t\ 4743}#
+ '((%%args
+ (error "wrong number of arguments"
+ %%args))))))
+ #{src\ 4724}#))))))))))))
+ (#{build-case-lambda\ 3770}#
+ (lambda (#{src\ 4744}#
+ #{docstring\ 4745}#
+ #{body\ 4746}#)
+ (let ((#{atom-key\ 4747}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4747}# (quote (c)))
+ ((@ (language tree-il) make-lambda)
+ #{src\ 4744}#
+ (if #{docstring\ 4745}#
+ (list (cons (quote documentation) #{docstring\ 4745}#))
+ '())
+ #{body\ 4746}#)
+ (#{decorate-source\ 3758}#
+ (cons 'lambda
+ (cons '%%args
+ (append
+ (if #{docstring\ 4745}#
+ (list #{docstring\ 4745}#)
+ '())
+ (list (cons (quote cond) #{body\ 4746}#)))))
+ #{src\ 4744}#)))))
+ (#{build-simple-lambda\ 3769}#
+ (lambda (#{src\ 4748}#
+ #{req\ 4749}#
+ #{rest\ 4750}#
+ #{vars\ 4751}#
+ #{docstring\ 4752}#
+ #{exp\ 4753}#)
+ (let ((#{atom-key\ 4754}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4754}# (quote (c)))
((@ (language tree-il) make-lambda)
- #{src\ 1989}#
- #{ids\ 1990}#
- #{vars\ 1991}#
- (if #{docstring\ 1992}#
- (list (cons (quote documentation) #{docstring\ 1992}#))
+ #{src\ 4748}#
+ (if #{docstring\ 4752}#
+ (list (cons (quote documentation) #{docstring\ 4752}#))
'())
- #{exp\ 1993}#)
- (#{decorate-source\ 1262}#
+ ((@ (language tree-il) make-lambda-case)
+ #{src\ 4748}#
+ #{req\ 4749}#
+ #f
+ #{rest\ 4750}#
+ #f
+ '()
+ #{vars\ 4751}#
+ #{exp\ 4753}#
+ #f))
+ (#{decorate-source\ 3758}#
(cons 'lambda
- (cons #{vars\ 1991}#
+ (cons (if #{rest\ 4750}#
+ (apply cons* #{vars\ 4751}#)
+ #{vars\ 4751}#)
(append
- (if #{docstring\ 1992}#
- (list #{docstring\ 1992}#)
+ (if #{docstring\ 4752}#
+ (list #{docstring\ 4752}#)
'())
- (list #{exp\ 1993}#))))
- #{src\ 1989}#)))))
- (#{build-global-definition\ 1272}#
- (lambda (#{source\ 1995}# #{var\ 1996}# #{exp\ 1997}#)
- (let ((#{atom-key\ 1998}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1998}# (quote (c)))
+ (list #{exp\ 4753}#))))
+ #{src\ 4748}#)))))
+ (#{build-global-definition\ 3768}#
+ (lambda (#{source\ 4755}# #{var\ 4756}# #{exp\ 4757}#)
+ (let ((#{atom-key\ 4758}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4758}# (quote (c)))
(begin
- (#{maybe-name-value!\ 1271}#
- #{var\ 1996}#
- #{exp\ 1997}#)
+ (#{maybe-name-value!\ 3767}#
+ #{var\ 4756}#
+ #{exp\ 4757}#)
((@ (language tree-il) make-toplevel-define)
- #{source\ 1995}#
- #{var\ 1996}#
- #{exp\ 1997}#))
- (#{decorate-source\ 1262}#
- (list (quote define) #{var\ 1996}# #{exp\ 1997}#)
- #{source\ 1995}#)))))
- (#{maybe-name-value!\ 1271}#
- (lambda (#{name\ 1999}# #{val\ 2000}#)
- (if ((@ (language tree-il) lambda?) #{val\ 2000}#)
- (let ((#{meta\ 2001}#
+ #{source\ 4755}#
+ #{var\ 4756}#
+ #{exp\ 4757}#))
+ (#{decorate-source\ 3758}#
+ (list (quote define) #{var\ 4756}# #{exp\ 4757}#)
+ #{source\ 4755}#)))))
+ (#{maybe-name-value!\ 3767}#
+ (lambda (#{name\ 4759}# #{val\ 4760}#)
+ (if ((@ (language tree-il) lambda?) #{val\ 4760}#)
+ (let ((#{meta\ 4761}#
((@ (language tree-il) lambda-meta)
- #{val\ 2000}#)))
- (if (not (assq (quote name) #{meta\ 2001}#))
+ #{val\ 4760}#)))
+ (if (not (assq (quote name) #{meta\ 4761}#))
((setter (@ (language tree-il) lambda-meta))
- #{val\ 2000}#
+ #{val\ 4760}#
(acons 'name
- #{name\ 1999}#
- #{meta\ 2001}#)))))))
- (#{build-global-assignment\ 1270}#
- (lambda (#{source\ 2002}#
- #{var\ 2003}#
- #{exp\ 2004}#
- #{mod\ 2005}#)
- (#{analyze-variable\ 1268}#
- #{mod\ 2005}#
- #{var\ 2003}#
- (lambda (#{mod\ 2006}# #{var\ 2007}# #{public?\ 2008}#)
- (let ((#{atom-key\ 2009}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2009}# (quote (c)))
+ #{name\ 4759}#
+ #{meta\ 4761}#)))))))
+ (#{build-global-assignment\ 3766}#
+ (lambda (#{source\ 4762}#
+ #{var\ 4763}#
+ #{exp\ 4764}#
+ #{mod\ 4765}#)
+ (#{analyze-variable\ 3764}#
+ #{mod\ 4765}#
+ #{var\ 4763}#
+ (lambda (#{mod\ 4766}# #{var\ 4767}# #{public?\ 4768}#)
+ (let ((#{atom-key\ 4769}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4769}# (quote (c)))
((@ (language tree-il) make-module-set)
- #{source\ 2002}#
- #{mod\ 2006}#
- #{var\ 2007}#
- #{public?\ 2008}#
- #{exp\ 2004}#)
- (#{decorate-source\ 1262}#
+ #{source\ 4762}#
+ #{mod\ 4766}#
+ #{var\ 4767}#
+ #{public?\ 4768}#
+ #{exp\ 4764}#)
+ (#{decorate-source\ 3758}#
(list 'set!
- (list (if #{public?\ 2008}#
+ (list (if #{public?\ 4768}#
'@
'@@)
- #{mod\ 2006}#
- #{var\ 2007}#)
- #{exp\ 2004}#)
- #{source\ 2002}#))))
- (lambda (#{var\ 2010}#)
- (let ((#{atom-key\ 2011}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2011}# (quote (c)))
+ #{mod\ 4766}#
+ #{var\ 4767}#)
+ #{exp\ 4764}#)
+ #{source\ 4762}#))))
+ (lambda (#{var\ 4770}#)
+ (let ((#{atom-key\ 4771}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4771}# (quote (c)))
((@ (language tree-il) make-toplevel-set)
- #{source\ 2002}#
- #{var\ 2010}#
- #{exp\ 2004}#)
- (#{decorate-source\ 1262}#
- (list (quote set!) #{var\ 2010}# #{exp\ 2004}#)
- #{source\ 2002}#)))))))
- (#{build-global-reference\ 1269}#
- (lambda (#{source\ 2012}# #{var\ 2013}# #{mod\ 2014}#)
- (#{analyze-variable\ 1268}#
- #{mod\ 2014}#
- #{var\ 2013}#
- (lambda (#{mod\ 2015}# #{var\ 2016}# #{public?\ 2017}#)
- (let ((#{atom-key\ 2018}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2018}# (quote (c)))
+ #{source\ 4762}#
+ #{var\ 4770}#
+ #{exp\ 4764}#)
+ (#{decorate-source\ 3758}#
+ (list (quote set!) #{var\ 4770}# #{exp\ 4764}#)
+ #{source\ 4762}#)))))))
+ (#{build-global-reference\ 3765}#
+ (lambda (#{source\ 4772}# #{var\ 4773}# #{mod\ 4774}#)
+ (#{analyze-variable\ 3764}#
+ #{mod\ 4774}#
+ #{var\ 4773}#
+ (lambda (#{mod\ 4775}# #{var\ 4776}# #{public?\ 4777}#)
+ (let ((#{atom-key\ 4778}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4778}# (quote (c)))
((@ (language tree-il) make-module-ref)
- #{source\ 2012}#
- #{mod\ 2015}#
- #{var\ 2016}#
- #{public?\ 2017}#)
- (#{decorate-source\ 1262}#
- (list (if #{public?\ 2017}# (quote @) (quote @@))
- #{mod\ 2015}#
- #{var\ 2016}#)
- #{source\ 2012}#))))
- (lambda (#{var\ 2019}#)
- (let ((#{atom-key\ 2020}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2020}# (quote (c)))
+ #{source\ 4772}#
+ #{mod\ 4775}#
+ #{var\ 4776}#
+ #{public?\ 4777}#)
+ (#{decorate-source\ 3758}#
+ (list (if #{public?\ 4777}# (quote @) (quote @@))
+ #{mod\ 4775}#
+ #{var\ 4776}#)
+ #{source\ 4772}#))))
+ (lambda (#{var\ 4779}#)
+ (let ((#{atom-key\ 4780}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4780}# (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- #{source\ 2012}#
- #{var\ 2019}#)
- (#{decorate-source\ 1262}#
- #{var\ 2019}#
- #{source\ 2012}#)))))))
- (#{analyze-variable\ 1268}#
- (lambda (#{mod\ 2021}#
- #{var\ 2022}#
- #{modref-cont\ 2023}#
- #{bare-cont\ 2024}#)
- (if (not #{mod\ 2021}#)
- (#{bare-cont\ 2024}# #{var\ 2022}#)
- (let ((#{kind\ 2025}# (car #{mod\ 2021}#))
- (#{mod\ 2026}# (cdr #{mod\ 2021}#)))
- (if (memv #{kind\ 2025}# (quote (public)))
- (#{modref-cont\ 2023}#
- #{mod\ 2026}#
- #{var\ 2022}#
+ #{source\ 4772}#
+ #{var\ 4779}#)
+ (#{decorate-source\ 3758}#
+ #{var\ 4779}#
+ #{source\ 4772}#)))))))
+ (#{analyze-variable\ 3764}#
+ (lambda (#{mod\ 4781}#
+ #{var\ 4782}#
+ #{modref-cont\ 4783}#
+ #{bare-cont\ 4784}#)
+ (if (not #{mod\ 4781}#)
+ (#{bare-cont\ 4784}# #{var\ 4782}#)
+ (let ((#{kind\ 4785}# (car #{mod\ 4781}#))
+ (#{mod\ 4786}# (cdr #{mod\ 4781}#)))
+ (if (memv #{kind\ 4785}# (quote (public)))
+ (#{modref-cont\ 4783}#
+ #{mod\ 4786}#
+ #{var\ 4782}#
#t)
- (if (memv #{kind\ 2025}# (quote (private)))
+ (if (memv #{kind\ 4785}# (quote (private)))
(if (not (equal?
- #{mod\ 2026}#
+ #{mod\ 4786}#
(module-name (current-module))))
- (#{modref-cont\ 2023}#
- #{mod\ 2026}#
- #{var\ 2022}#
+ (#{modref-cont\ 4783}#
+ #{mod\ 4786}#
+ #{var\ 4782}#
#f)
- (#{bare-cont\ 2024}# #{var\ 2022}#))
- (if (memv #{kind\ 2025}# (quote (bare)))
- (#{bare-cont\ 2024}# #{var\ 2022}#)
- (if (memv #{kind\ 2025}# (quote (hygiene)))
+ (#{bare-cont\ 4784}# #{var\ 4782}#))
+ (if (memv #{kind\ 4785}# (quote (bare)))
+ (#{bare-cont\ 4784}# #{var\ 4782}#)
+ (if (memv #{kind\ 4785}# (quote (hygiene)))
(if (if (not (equal?
- #{mod\ 2026}#
+ #{mod\ 4786}#
(module-name (current-module))))
(module-variable
- (resolve-module #{mod\ 2026}#)
- #{var\ 2022}#)
+ (resolve-module #{mod\ 4786}#)
+ #{var\ 4782}#)
#f)
- (#{modref-cont\ 2023}#
- #{mod\ 2026}#
- #{var\ 2022}#
+ (#{modref-cont\ 4783}#
+ #{mod\ 4786}#
+ #{var\ 4782}#
#f)
- (#{bare-cont\ 2024}# #{var\ 2022}#))
+ (#{bare-cont\ 4784}# #{var\ 4782}#))
(syntax-violation
#f
"bad module kind"
- #{var\ 2022}#
- #{mod\ 2026}#)))))))))
- (#{build-lexical-assignment\ 1267}#
- (lambda (#{source\ 2027}#
- #{name\ 2028}#
- #{var\ 2029}#
- #{exp\ 2030}#)
- (let ((#{atom-key\ 2031}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2031}# (quote (c)))
+ #{var\ 4782}#
+ #{mod\ 4786}#)))))))))
+ (#{build-lexical-assignment\ 3763}#
+ (lambda (#{source\ 4787}#
+ #{name\ 4788}#
+ #{var\ 4789}#
+ #{exp\ 4790}#)
+ (let ((#{atom-key\ 4791}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4791}# (quote (c)))
((@ (language tree-il) make-lexical-set)
- #{source\ 2027}#
- #{name\ 2028}#
- #{var\ 2029}#
- #{exp\ 2030}#)
- (#{decorate-source\ 1262}#
- (list (quote set!) #{var\ 2029}# #{exp\ 2030}#)
- #{source\ 2027}#)))))
- (#{build-lexical-reference\ 1266}#
- (lambda (#{type\ 2032}#
- #{source\ 2033}#
- #{name\ 2034}#
- #{var\ 2035}#)
- (let ((#{atom-key\ 2036}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2036}# (quote (c)))
+ #{source\ 4787}#
+ #{name\ 4788}#
+ #{var\ 4789}#
+ #{exp\ 4790}#)
+ (#{decorate-source\ 3758}#
+ (list (quote set!) #{var\ 4789}# #{exp\ 4790}#)
+ #{source\ 4787}#)))))
+ (#{build-lexical-reference\ 3762}#
+ (lambda (#{type\ 4792}#
+ #{source\ 4793}#
+ #{name\ 4794}#
+ #{var\ 4795}#)
+ (let ((#{atom-key\ 4796}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4796}# (quote (c)))
((@ (language tree-il) make-lexical-ref)
- #{source\ 2033}#
- #{name\ 2034}#
- #{var\ 2035}#)
- (#{decorate-source\ 1262}#
- #{var\ 2035}#
- #{source\ 2033}#)))))
- (#{build-conditional\ 1265}#
- (lambda (#{source\ 2037}#
- #{test-exp\ 2038}#
- #{then-exp\ 2039}#
- #{else-exp\ 2040}#)
- (let ((#{atom-key\ 2041}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2041}# (quote (c)))
+ #{source\ 4793}#
+ #{name\ 4794}#
+ #{var\ 4795}#)
+ (#{decorate-source\ 3758}#
+ #{var\ 4795}#
+ #{source\ 4793}#)))))
+ (#{build-conditional\ 3761}#
+ (lambda (#{source\ 4797}#
+ #{test-exp\ 4798}#
+ #{then-exp\ 4799}#
+ #{else-exp\ 4800}#)
+ (let ((#{atom-key\ 4801}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4801}# (quote (c)))
((@ (language tree-il) make-conditional)
- #{source\ 2037}#
- #{test-exp\ 2038}#
- #{then-exp\ 2039}#
- #{else-exp\ 2040}#)
- (#{decorate-source\ 1262}#
- (if (equal? #{else-exp\ 2040}# (quote (if #f #f)))
+ #{source\ 4797}#
+ #{test-exp\ 4798}#
+ #{then-exp\ 4799}#
+ #{else-exp\ 4800}#)
+ (#{decorate-source\ 3758}#
+ (if (equal? #{else-exp\ 4800}# (quote (if #f #f)))
(list 'if
- #{test-exp\ 2038}#
- #{then-exp\ 2039}#)
+ #{test-exp\ 4798}#
+ #{then-exp\ 4799}#)
(list 'if
- #{test-exp\ 2038}#
- #{then-exp\ 2039}#
- #{else-exp\ 2040}#))
- #{source\ 2037}#)))))
- (#{build-application\ 1264}#
- (lambda (#{source\ 2042}#
- #{fun-exp\ 2043}#
- #{arg-exps\ 2044}#)
- (let ((#{atom-key\ 2045}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2045}# (quote (c)))
+ #{test-exp\ 4798}#
+ #{then-exp\ 4799}#
+ #{else-exp\ 4800}#))
+ #{source\ 4797}#)))))
+ (#{build-application\ 3760}#
+ (lambda (#{source\ 4802}#
+ #{fun-exp\ 4803}#
+ #{arg-exps\ 4804}#)
+ (let ((#{atom-key\ 4805}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4805}# (quote (c)))
((@ (language tree-il) make-application)
- #{source\ 2042}#
- #{fun-exp\ 2043}#
- #{arg-exps\ 2044}#)
- (#{decorate-source\ 1262}#
- (cons #{fun-exp\ 2043}# #{arg-exps\ 2044}#)
- #{source\ 2042}#)))))
- (#{build-void\ 1263}#
- (lambda (#{source\ 2046}#)
- (let ((#{atom-key\ 2047}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2047}# (quote (c)))
+ #{source\ 4802}#
+ #{fun-exp\ 4803}#
+ #{arg-exps\ 4804}#)
+ (#{decorate-source\ 3758}#
+ (cons #{fun-exp\ 4803}# #{arg-exps\ 4804}#)
+ #{source\ 4802}#)))))
+ (#{build-void\ 3759}#
+ (lambda (#{source\ 4806}#)
+ (let ((#{atom-key\ 4807}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4807}# (quote (c)))
((@ (language tree-il) make-void)
- #{source\ 2046}#)
- (#{decorate-source\ 1262}#
+ #{source\ 4806}#)
+ (#{decorate-source\ 3758}#
'(if #f #f)
- #{source\ 2046}#)))))
- (#{decorate-source\ 1262}#
- (lambda (#{e\ 2048}# #{s\ 2049}#)
+ #{source\ 4806}#)))))
+ (#{decorate-source\ 3758}#
+ (lambda (#{e\ 4808}# #{s\ 4809}#)
(begin
- (if (if (pair? #{e\ 2048}#) #{s\ 2049}# #f)
- (set-source-properties! #{e\ 2048}# #{s\ 2049}#))
- #{e\ 2048}#)))
- (#{get-global-definition-hook\ 1261}#
- (lambda (#{symbol\ 2050}# #{module\ 2051}#)
+ (if (if (pair? #{e\ 4808}#) #{s\ 4809}# #f)
+ (set-source-properties! #{e\ 4808}# #{s\ 4809}#))
+ #{e\ 4808}#)))
+ (#{get-global-definition-hook\ 3757}#
+ (lambda (#{symbol\ 4810}# #{module\ 4811}#)
(begin
- (if (if (not #{module\ 2051}#) (current-module) #f)
+ (if (if (not #{module\ 4811}#) (current-module) #f)
(warn "module system is booted, we should have a module"
- #{symbol\ 2050}#))
- (let ((#{v\ 2052}#
+ #{symbol\ 4810}#))
+ (let ((#{v\ 4812}#
(module-variable
- (if #{module\ 2051}#
- (resolve-module (cdr #{module\ 2051}#))
+ (if #{module\ 4811}#
+ (resolve-module (cdr #{module\ 4811}#))
(current-module))
- #{symbol\ 2050}#)))
- (if #{v\ 2052}#
- (if (variable-bound? #{v\ 2052}#)
- (let ((#{val\ 2053}# (variable-ref #{v\ 2052}#)))
- (if (macro? #{val\ 2053}#)
- (if (syncase-macro-type #{val\ 2053}#)
- (cons (syncase-macro-type #{val\ 2053}#)
- (syncase-macro-binding #{val\ 2053}#))
+ #{symbol\ 4810}#)))
+ (if #{v\ 4812}#
+ (if (variable-bound? #{v\ 4812}#)
+ (let ((#{val\ 4813}# (variable-ref #{v\ 4812}#)))
+ (if (macro? #{val\ 4813}#)
+ (if (syncase-macro-type #{val\ 4813}#)
+ (cons (syncase-macro-type #{val\ 4813}#)
+ (syncase-macro-binding #{val\ 4813}#))
#f)
#f))
#f)
#f)))))
- (#{put-global-definition-hook\ 1260}#
- (lambda (#{symbol\ 2054}# #{type\ 2055}# #{val\ 2056}#)
- (let ((#{existing\ 2057}#
- (let ((#{v\ 2058}#
+ (#{put-global-definition-hook\ 3756}#
+ (lambda (#{symbol\ 4814}# #{type\ 4815}# #{val\ 4816}#)
+ (let ((#{existing\ 4817}#
+ (let ((#{v\ 4818}#
(module-variable
(current-module)
- #{symbol\ 2054}#)))
- (if #{v\ 2058}#
- (if (variable-bound? #{v\ 2058}#)
- (let ((#{val\ 2059}# (variable-ref #{v\ 2058}#)))
- (if (macro? #{val\ 2059}#)
- (if (not (syncase-macro-type #{val\ 2059}#))
- #{val\ 2059}#
+ #{symbol\ 4814}#)))
+ (if #{v\ 4818}#
+ (if (variable-bound? #{v\ 4818}#)
+ (let ((#{val\ 4819}# (variable-ref #{v\ 4818}#)))
+ (if (macro? #{val\ 4819}#)
+ (if (not (syncase-macro-type #{val\ 4819}#))
+ #{val\ 4819}#
#f)
#f))
#f)
#f))))
(module-define!
(current-module)
- #{symbol\ 2054}#
- (if #{existing\ 2057}#
+ #{symbol\ 4814}#
+ (if #{existing\ 4817}#
(make-extended-syncase-macro
- #{existing\ 2057}#
- #{type\ 2055}#
- #{val\ 2056}#)
- (make-syncase-macro #{type\ 2055}# #{val\ 2056}#))))))
- (#{local-eval-hook\ 1259}#
- (lambda (#{x\ 2060}# #{mod\ 2061}#)
+ #{existing\ 4817}#
+ #{type\ 4815}#
+ #{val\ 4816}#)
+ (make-syncase-macro #{type\ 4815}# #{val\ 4816}#))))))
+ (#{local-eval-hook\ 3755}#
+ (lambda (#{x\ 4820}# #{mod\ 4821}#)
(primitive-eval
- (list #{noexpand\ 1252}#
- (let ((#{atom-key\ 2062}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2062}# (quote (c)))
+ (list #{noexpand\ 3748}#
+ (let ((#{atom-key\ 4822}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4822}# (quote (c)))
((@ (language tree-il) tree-il->scheme)
- #{x\ 2060}#)
- #{x\ 2060}#))))))
- (#{top-level-eval-hook\ 1258}#
- (lambda (#{x\ 2063}# #{mod\ 2064}#)
+ #{x\ 4820}#)
+ #{x\ 4820}#))))))
+ (#{top-level-eval-hook\ 3754}#
+ (lambda (#{x\ 4823}# #{mod\ 4824}#)
(primitive-eval
- (list #{noexpand\ 1252}#
- (let ((#{atom-key\ 2065}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2065}# (quote (c)))
+ (list #{noexpand\ 3748}#
+ (let ((#{atom-key\ 4825}# (fluid-ref #{*mode*\ 3749}#)))
+ (if (memv #{atom-key\ 4825}# (quote (c)))
((@ (language tree-il) tree-il->scheme)
- #{x\ 2063}#)
- #{x\ 2063}#))))))
- (#{fx<\ 1257}# <)
- (#{fx=\ 1256}# =)
- (#{fx-\ 1255}# -)
- (#{fx+\ 1254}# +)
- (#{*mode*\ 1253}# (make-fluid))
- (#{noexpand\ 1252}# "noexpand"))
+ #{x\ 4823}#)
+ #{x\ 4823}#))))))
+ (#{fx<\ 3753}# <)
+ (#{fx=\ 3752}# =)
+ (#{fx-\ 3751}# -)
+ (#{fx+\ 3750}# +)
+ (#{*mode*\ 3749}# (make-fluid))
+ (#{noexpand\ 3748}# "noexpand"))
(begin
- (#{global-extend\ 1295}#
+ (#{global-extend\ 3793}#
'local-syntax
'letrec-syntax
#t)
- (#{global-extend\ 1295}#
+ (#{global-extend\ 3793}#
'local-syntax
'let-syntax
#f)
- (#{global-extend\ 1295}#
+ (#{global-extend\ 3793}#
'core
'fluid-let-syntax
- (lambda (#{e\ 2066}#
- #{r\ 2067}#
- #{w\ 2068}#
- #{s\ 2069}#
- #{mod\ 2070}#)
- ((lambda (#{tmp\ 2071}#)
- ((lambda (#{tmp\ 2072}#)
- (if (if #{tmp\ 2072}#
- (apply (lambda (#{_\ 2073}#
- #{var\ 2074}#
- #{val\ 2075}#
- #{e1\ 2076}#
- #{e2\ 2077}#)
- (#{valid-bound-ids?\ 1322}# #{var\ 2074}#))
- #{tmp\ 2072}#)
+ (lambda (#{e\ 4826}#
+ #{r\ 4827}#
+ #{w\ 4828}#
+ #{s\ 4829}#
+ #{mod\ 4830}#)
+ ((lambda (#{tmp\ 4831}#)
+ ((lambda (#{tmp\ 4832}#)
+ (if (if #{tmp\ 4832}#
+ (apply (lambda (#{_\ 4833}#
+ #{var\ 4834}#
+ #{val\ 4835}#
+ #{e1\ 4836}#
+ #{e2\ 4837}#)
+ (#{valid-bound-ids?\ 3820}# #{var\ 4834}#))
+ #{tmp\ 4832}#)
#f)
- (apply (lambda (#{_\ 2079}#
- #{var\ 2080}#
- #{val\ 2081}#
- #{e1\ 2082}#
- #{e2\ 2083}#)
- (let ((#{names\ 2084}#
- (map (lambda (#{x\ 2085}#)
- (#{id-var-name\ 1319}#
- #{x\ 2085}#
- #{w\ 2068}#))
- #{var\ 2080}#)))
+ (apply (lambda (#{_\ 4839}#
+ #{var\ 4840}#
+ #{val\ 4841}#
+ #{e1\ 4842}#
+ #{e2\ 4843}#)
+ (let ((#{names\ 4844}#
+ (map (lambda (#{x\ 4845}#)
+ (#{id-var-name\ 3817}#
+ #{x\ 4845}#
+ #{w\ 4828}#))
+ #{var\ 4840}#)))
(begin
(for-each
- (lambda (#{id\ 2087}# #{n\ 2088}#)
- (let ((#{atom-key\ 2089}#
- (#{binding-type\ 1289}#
- (#{lookup\ 1294}#
- #{n\ 2088}#
- #{r\ 2067}#
- #{mod\ 2070}#))))
- (if (memv #{atom-key\ 2089}#
+ (lambda (#{id\ 4847}# #{n\ 4848}#)
+ (let ((#{atom-key\ 4849}#
+ (#{binding-type\ 3787}#
+ (#{lookup\ 3792}#
+ #{n\ 4848}#
+ #{r\ 4827}#
+ #{mod\ 4830}#))))
+ (if (memv #{atom-key\ 4849}#
'(displaced-lexical))
(syntax-violation
'fluid-let-syntax
"identifier out of context"
- #{e\ 2066}#
- (#{source-wrap\ 1326}#
- #{id\ 2087}#
- #{w\ 2068}#
- #{s\ 2069}#
- #{mod\ 2070}#)))))
- #{var\ 2080}#
- #{names\ 2084}#)
- (#{chi-body\ 1337}#
- (cons #{e1\ 2082}# #{e2\ 2083}#)
- (#{source-wrap\ 1326}#
- #{e\ 2066}#
- #{w\ 2068}#
- #{s\ 2069}#
- #{mod\ 2070}#)
- (#{extend-env\ 1291}#
- #{names\ 2084}#
- (let ((#{trans-r\ 2092}#
- (#{macros-only-env\ 1293}#
- #{r\ 2067}#)))
- (map (lambda (#{x\ 2093}#)
+ #{e\ 4826}#
+ (#{source-wrap\ 3824}#
+ #{id\ 4847}#
+ #{w\ 4828}#
+ #{s\ 4829}#
+ #{mod\ 4830}#)))))
+ #{var\ 4840}#
+ #{names\ 4844}#)
+ (#{chi-body\ 3835}#
+ (cons #{e1\ 4842}# #{e2\ 4843}#)
+ (#{source-wrap\ 3824}#
+ #{e\ 4826}#
+ #{w\ 4828}#
+ #{s\ 4829}#
+ #{mod\ 4830}#)
+ (#{extend-env\ 3789}#
+ #{names\ 4844}#
+ (let ((#{trans-r\ 4852}#
+ (#{macros-only-env\ 3791}#
+ #{r\ 4827}#)))
+ (map (lambda (#{x\ 4853}#)
(cons 'macro
- (#{eval-local-transformer\ 1340}#
- (#{chi\ 1333}#
- #{x\ 2093}#
- #{trans-r\ 2092}#
- #{w\ 2068}#
- #{mod\ 2070}#)
- #{mod\ 2070}#)))
- #{val\ 2081}#))
- #{r\ 2067}#)
- #{w\ 2068}#
- #{mod\ 2070}#))))
- #{tmp\ 2072}#)
- ((lambda (#{_\ 2095}#)
+ (#{eval-local-transformer\ 3837}#
+ (#{chi\ 3831}#
+ #{x\ 4853}#
+ #{trans-r\ 4852}#
+ #{w\ 4828}#
+ #{mod\ 4830}#)
+ #{mod\ 4830}#)))
+ #{val\ 4841}#))
+ #{r\ 4827}#)
+ #{w\ 4828}#
+ #{mod\ 4830}#))))
+ #{tmp\ 4832}#)
+ ((lambda (#{_\ 4855}#)
(syntax-violation
'fluid-let-syntax
"bad syntax"
- (#{source-wrap\ 1326}#
- #{e\ 2066}#
- #{w\ 2068}#
- #{s\ 2069}#
- #{mod\ 2070}#)))
- #{tmp\ 2071}#)))
+ (#{source-wrap\ 3824}#
+ #{e\ 4826}#
+ #{w\ 4828}#
+ #{s\ 4829}#
+ #{mod\ 4830}#)))
+ #{tmp\ 4831}#)))
($sc-dispatch
- #{tmp\ 2071}#
+ #{tmp\ 4831}#
'(any #(each (any any)) any . each-any))))
- #{e\ 2066}#)))
- (#{global-extend\ 1295}#
+ #{e\ 4826}#)))
+ (#{global-extend\ 3793}#
'core
'quote
- (lambda (#{e\ 2096}#
- #{r\ 2097}#
- #{w\ 2098}#
- #{s\ 2099}#
- #{mod\ 2100}#)
- ((lambda (#{tmp\ 2101}#)
- ((lambda (#{tmp\ 2102}#)
- (if #{tmp\ 2102}#
- (apply (lambda (#{_\ 2103}# #{e\ 2104}#)
- (#{build-data\ 1275}#
- #{s\ 2099}#
- (#{strip\ 1343}# #{e\ 2104}# #{w\ 2098}#)))
- #{tmp\ 2102}#)
- ((lambda (#{_\ 2105}#)
+ (lambda (#{e\ 4856}#
+ #{r\ 4857}#
+ #{w\ 4858}#
+ #{s\ 4859}#
+ #{mod\ 4860}#)
+ ((lambda (#{tmp\ 4861}#)
+ ((lambda (#{tmp\ 4862}#)
+ (if #{tmp\ 4862}#
+ (apply (lambda (#{_\ 4863}# #{e\ 4864}#)
+ (#{build-data\ 3773}#
+ #{s\ 4859}#
+ (#{strip\ 3844}# #{e\ 4864}# #{w\ 4858}#)))
+ #{tmp\ 4862}#)
+ ((lambda (#{_\ 4865}#)
(syntax-violation
'quote
"bad syntax"
- (#{source-wrap\ 1326}#
- #{e\ 2096}#
- #{w\ 2098}#
- #{s\ 2099}#
- #{mod\ 2100}#)))
- #{tmp\ 2101}#)))
- ($sc-dispatch #{tmp\ 2101}# (quote (any any)))))
- #{e\ 2096}#)))
- (#{global-extend\ 1295}#
+ (#{source-wrap\ 3824}#
+ #{e\ 4856}#
+ #{w\ 4858}#
+ #{s\ 4859}#
+ #{mod\ 4860}#)))
+ #{tmp\ 4861}#)))
+ ($sc-dispatch #{tmp\ 4861}# (quote (any any)))))
+ #{e\ 4856}#)))
+ (#{global-extend\ 3793}#
'core
'syntax
- (letrec ((#{regen\ 2113}#
- (lambda (#{x\ 2114}#)
- (let ((#{atom-key\ 2115}# (car #{x\ 2114}#)))
- (if (memv #{atom-key\ 2115}# (quote (ref)))
- (#{build-lexical-reference\ 1266}#
+ (letrec ((#{regen\ 4873}#
+ (lambda (#{x\ 4874}#)
+ (let ((#{atom-key\ 4875}# (car #{x\ 4874}#)))
+ (if (memv #{atom-key\ 4875}# (quote (ref)))
+ (#{build-lexical-reference\ 3762}#
'value
#f
- (cadr #{x\ 2114}#)
- (cadr #{x\ 2114}#))
- (if (memv #{atom-key\ 2115}# (quote (primitive)))
- (#{build-primref\ 1274}# #f (cadr #{x\ 2114}#))
- (if (memv #{atom-key\ 2115}# (quote (quote)))
- (#{build-data\ 1275}# #f (cadr #{x\ 2114}#))
- (if (memv #{atom-key\ 2115}# (quote (lambda)))
- (#{build-lambda\ 1273}#
- #f
- (cadr #{x\ 2114}#)
- (cadr #{x\ 2114}#)
- #f
- (#{regen\ 2113}# (caddr #{x\ 2114}#)))
- (#{build-application\ 1264}#
+ (cadr #{x\ 4874}#)
+ (cadr #{x\ 4874}#))
+ (if (memv #{atom-key\ 4875}# (quote (primitive)))
+ (#{build-primref\ 3772}# #f (cadr #{x\ 4874}#))
+ (if (memv #{atom-key\ 4875}# (quote (quote)))
+ (#{build-data\ 3773}# #f (cadr #{x\ 4874}#))
+ (if (memv #{atom-key\ 4875}# (quote (lambda)))
+ (if (list? (cadr #{x\ 4874}#))
+ (#{build-simple-lambda\ 3769}#
+ #f
+ (cadr #{x\ 4874}#)
+ #f
+ (cadr #{x\ 4874}#)
+ #f
+ (#{regen\ 4873}# (caddr #{x\ 4874}#)))
+ (error "how did we get here" #{x\ 4874}#))
+ (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}# #f (car #{x\ 2114}#))
- (map #{regen\ 2113}#
- (cdr #{x\ 2114}#))))))))))
- (#{gen-vector\ 2112}#
- (lambda (#{x\ 2116}#)
- (if (eq? (car #{x\ 2116}#) (quote list))
- (cons (quote vector) (cdr #{x\ 2116}#))
- (if (eq? (car #{x\ 2116}#) (quote quote))
+ (#{build-primref\ 3772}# #f (car #{x\ 4874}#))
+ (map #{regen\ 4873}#
+ (cdr #{x\ 4874}#))))))))))
+ (#{gen-vector\ 4872}#
+ (lambda (#{x\ 4876}#)
+ (if (eq? (car #{x\ 4876}#) (quote list))
+ (cons (quote vector) (cdr #{x\ 4876}#))
+ (if (eq? (car #{x\ 4876}#) (quote quote))
(list 'quote
- (list->vector (cadr #{x\ 2116}#)))
- (list (quote list->vector) #{x\ 2116}#)))))
- (#{gen-append\ 2111}#
- (lambda (#{x\ 2117}# #{y\ 2118}#)
- (if (equal? #{y\ 2118}# (quote (quote ())))
- #{x\ 2117}#
- (list (quote append) #{x\ 2117}# #{y\ 2118}#))))
- (#{gen-cons\ 2110}#
- (lambda (#{x\ 2119}# #{y\ 2120}#)
- (let ((#{atom-key\ 2121}# (car #{y\ 2120}#)))
- (if (memv #{atom-key\ 2121}# (quote (quote)))
- (if (eq? (car #{x\ 2119}#) (quote quote))
+ (list->vector (cadr #{x\ 4876}#)))
+ (list (quote list->vector) #{x\ 4876}#)))))
+ (#{gen-append\ 4871}#
+ (lambda (#{x\ 4877}# #{y\ 4878}#)
+ (if (equal? #{y\ 4878}# (quote (quote ())))
+ #{x\ 4877}#
+ (list (quote append) #{x\ 4877}# #{y\ 4878}#))))
+ (#{gen-cons\ 4870}#
+ (lambda (#{x\ 4879}# #{y\ 4880}#)
+ (let ((#{atom-key\ 4881}# (car #{y\ 4880}#)))
+ (if (memv #{atom-key\ 4881}# (quote (quote)))
+ (if (eq? (car #{x\ 4879}#) (quote quote))
(list 'quote
- (cons (cadr #{x\ 2119}#) (cadr #{y\ 2120}#)))
- (if (eq? (cadr #{y\ 2120}#) (quote ()))
- (list (quote list) #{x\ 2119}#)
- (list (quote cons) #{x\ 2119}# #{y\ 2120}#)))
- (if (memv #{atom-key\ 2121}# (quote (list)))
+ (cons (cadr #{x\ 4879}#) (cadr #{y\ 4880}#)))
+ (if (eq? (cadr #{y\ 4880}#) (quote ()))
+ (list (quote list) #{x\ 4879}#)
+ (list (quote cons) #{x\ 4879}# #{y\ 4880}#)))
+ (if (memv #{atom-key\ 4881}# (quote (list)))
(cons 'list
- (cons #{x\ 2119}# (cdr #{y\ 2120}#)))
- (list (quote cons) #{x\ 2119}# #{y\ 2120}#))))))
- (#{gen-map\ 2109}#
- (lambda (#{e\ 2122}# #{map-env\ 2123}#)
- (let ((#{formals\ 2124}# (map cdr #{map-env\ 2123}#))
- (#{actuals\ 2125}#
- (map (lambda (#{x\ 2126}#)
- (list (quote ref) (car #{x\ 2126}#)))
- #{map-env\ 2123}#)))
- (if (eq? (car #{e\ 2122}#) (quote ref))
- (car #{actuals\ 2125}#)
+ (cons #{x\ 4879}# (cdr #{y\ 4880}#)))
+ (list (quote cons) #{x\ 4879}# #{y\ 4880}#))))))
+ (#{gen-map\ 4869}#
+ (lambda (#{e\ 4882}# #{map-env\ 4883}#)
+ (let ((#{formals\ 4884}# (map cdr #{map-env\ 4883}#))
+ (#{actuals\ 4885}#
+ (map (lambda (#{x\ 4886}#)
+ (list (quote ref) (car #{x\ 4886}#)))
+ #{map-env\ 4883}#)))
+ (if (eq? (car #{e\ 4882}#) (quote ref))
+ (car #{actuals\ 4885}#)
(if (and-map
- (lambda (#{x\ 2127}#)
- (if (eq? (car #{x\ 2127}#) (quote ref))
- (memq (cadr #{x\ 2127}#) #{formals\ 2124}#)
+ (lambda (#{x\ 4887}#)
+ (if (eq? (car #{x\ 4887}#) (quote ref))
+ (memq (cadr #{x\ 4887}#) #{formals\ 4884}#)
#f))
- (cdr #{e\ 2122}#))
+ (cdr #{e\ 4882}#))
(cons 'map
(cons (list 'primitive
- (car #{e\ 2122}#))
- (map (let ((#{r\ 2128}#
+ (car #{e\ 4882}#))
+ (map (let ((#{r\ 4888}#
(map cons
- #{formals\ 2124}#
- #{actuals\ 2125}#)))
- (lambda (#{x\ 2129}#)
- (cdr (assq (cadr #{x\ 2129}#)
- #{r\ 2128}#))))
- (cdr #{e\ 2122}#))))
+ #{formals\ 4884}#
+ #{actuals\ 4885}#)))
+ (lambda (#{x\ 4889}#)
+ (cdr (assq (cadr #{x\ 4889}#)
+ #{r\ 4888}#))))
+ (cdr #{e\ 4882}#))))
(cons 'map
(cons (list 'lambda
- #{formals\ 2124}#
- #{e\ 2122}#)
- #{actuals\ 2125}#)))))))
- (#{gen-mappend\ 2108}#
- (lambda (#{e\ 2130}# #{map-env\ 2131}#)
+ #{formals\ 4884}#
+ #{e\ 4882}#)
+ #{actuals\ 4885}#)))))))
+ (#{gen-mappend\ 4868}#
+ (lambda (#{e\ 4890}# #{map-env\ 4891}#)
(list 'apply
'(primitive append)
- (#{gen-map\ 2109}# #{e\ 2130}# #{map-env\ 2131}#))))
- (#{gen-ref\ 2107}#
- (lambda (#{src\ 2132}#
- #{var\ 2133}#
- #{level\ 2134}#
- #{maps\ 2135}#)
- (if (#{fx=\ 1256}# #{level\ 2134}# 0)
- (values #{var\ 2133}# #{maps\ 2135}#)
- (if (null? #{maps\ 2135}#)
+ (#{gen-map\ 4869}# #{e\ 4890}# #{map-env\ 4891}#))))
+ (#{gen-ref\ 4867}#
+ (lambda (#{src\ 4892}#
+ #{var\ 4893}#
+ #{level\ 4894}#
+ #{maps\ 4895}#)
+ (if (#{fx=\ 3752}# #{level\ 4894}# 0)
+ (values #{var\ 4893}# #{maps\ 4895}#)
+ (if (null? #{maps\ 4895}#)
(syntax-violation
'syntax
"missing ellipsis"
- #{src\ 2132}#)
+ #{src\ 4892}#)
(call-with-values
(lambda ()
- (#{gen-ref\ 2107}#
- #{src\ 2132}#
- #{var\ 2133}#
- (#{fx-\ 1255}# #{level\ 2134}# 1)
- (cdr #{maps\ 2135}#)))
- (lambda (#{outer-var\ 2136}# #{outer-maps\ 2137}#)
- (let ((#{b\ 2138}#
- (assq #{outer-var\ 2136}#
- (car #{maps\ 2135}#))))
- (if #{b\ 2138}#
- (values (cdr #{b\ 2138}#) #{maps\ 2135}#)
- (let ((#{inner-var\ 2139}#
- (#{gen-var\ 1344}# (quote tmp))))
+ (#{gen-ref\ 4867}#
+ #{src\ 4892}#
+ #{var\ 4893}#
+ (#{fx-\ 3751}# #{level\ 4894}# 1)
+ (cdr #{maps\ 4895}#)))
+ (lambda (#{outer-var\ 4896}# #{outer-maps\ 4897}#)
+ (let ((#{b\ 4898}#
+ (assq #{outer-var\ 4896}#
+ (car #{maps\ 4895}#))))
+ (if #{b\ 4898}#
+ (values (cdr #{b\ 4898}#) #{maps\ 4895}#)
+ (let ((#{inner-var\ 4899}#
+ (#{gen-var\ 3845}# (quote tmp))))
(values
- #{inner-var\ 2139}#
- (cons (cons (cons #{outer-var\ 2136}#
- #{inner-var\ 2139}#)
- (car #{maps\ 2135}#))
- #{outer-maps\ 2137}#)))))))))))
- (#{gen-syntax\ 2106}#
- (lambda (#{src\ 2140}#
- #{e\ 2141}#
- #{r\ 2142}#
- #{maps\ 2143}#
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#)
- (if (#{id?\ 1297}# #{e\ 2141}#)
- (let ((#{label\ 2146}#
- (#{id-var-name\ 1319}#
- #{e\ 2141}#
+ #{inner-var\ 4899}#
+ (cons (cons (cons #{outer-var\ 4896}#
+ #{inner-var\ 4899}#)
+ (car #{maps\ 4895}#))
+ #{outer-maps\ 4897}#)))))))))))
+ (#{gen-syntax\ 4866}#
+ (lambda (#{src\ 4900}#
+ #{e\ 4901}#
+ #{r\ 4902}#
+ #{maps\ 4903}#
+ #{ellipsis?\ 4904}#
+ #{mod\ 4905}#)
+ (if (#{id?\ 3795}# #{e\ 4901}#)
+ (let ((#{label\ 4906}#
+ (#{id-var-name\ 3817}#
+ #{e\ 4901}#
'(()))))
- (let ((#{b\ 2147}#
- (#{lookup\ 1294}#
- #{label\ 2146}#
- #{r\ 2142}#
- #{mod\ 2145}#)))
- (if (eq? (#{binding-type\ 1289}# #{b\ 2147}#)
+ (let ((#{b\ 4907}#
+ (#{lookup\ 3792}#
+ #{label\ 4906}#
+ #{r\ 4902}#
+ #{mod\ 4905}#)))
+ (if (eq? (#{binding-type\ 3787}# #{b\ 4907}#)
'syntax)
(call-with-values
(lambda ()
- (let ((#{var.lev\ 2148}#
- (#{binding-value\ 1290}#
- #{b\ 2147}#)))
- (#{gen-ref\ 2107}#
- #{src\ 2140}#
- (car #{var.lev\ 2148}#)
- (cdr #{var.lev\ 2148}#)
- #{maps\ 2143}#)))
- (lambda (#{var\ 2149}# #{maps\ 2150}#)
+ (let ((#{var.lev\ 4908}#
+ (#{binding-value\ 3788}#
+ #{b\ 4907}#)))
+ (#{gen-ref\ 4867}#
+ #{src\ 4900}#
+ (car #{var.lev\ 4908}#)
+ (cdr #{var.lev\ 4908}#)
+ #{maps\ 4903}#)))
+ (lambda (#{var\ 4909}# #{maps\ 4910}#)
(values
- (list (quote ref) #{var\ 2149}#)
- #{maps\ 2150}#)))
- (if (#{ellipsis?\ 2144}# #{e\ 2141}#)
+ (list (quote ref) #{var\ 4909}#)
+ #{maps\ 4910}#)))
+ (if (#{ellipsis?\ 4904}# #{e\ 4901}#)
(syntax-violation
'syntax
"misplaced ellipsis"
- #{src\ 2140}#)
+ #{src\ 4900}#)
(values
- (list (quote quote) #{e\ 2141}#)
- #{maps\ 2143}#)))))
- ((lambda (#{tmp\ 2151}#)
- ((lambda (#{tmp\ 2152}#)
- (if (if #{tmp\ 2152}#
- (apply (lambda (#{dots\ 2153}# #{e\ 2154}#)
- (#{ellipsis?\ 2144}#
- #{dots\ 2153}#))
- #{tmp\ 2152}#)
+ (list (quote quote) #{e\ 4901}#)
+ #{maps\ 4903}#)))))
+ ((lambda (#{tmp\ 4911}#)
+ ((lambda (#{tmp\ 4912}#)
+ (if (if #{tmp\ 4912}#
+ (apply (lambda (#{dots\ 4913}# #{e\ 4914}#)
+ (#{ellipsis?\ 4904}#
+ #{dots\ 4913}#))
+ #{tmp\ 4912}#)
#f)
- (apply (lambda (#{dots\ 2155}# #{e\ 2156}#)
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{e\ 2156}#
- #{r\ 2142}#
- #{maps\ 2143}#
- (lambda (#{x\ 2157}#) #f)
- #{mod\ 2145}#))
- #{tmp\ 2152}#)
- ((lambda (#{tmp\ 2158}#)
- (if (if #{tmp\ 2158}#
- (apply (lambda (#{x\ 2159}#
- #{dots\ 2160}#
- #{y\ 2161}#)
- (#{ellipsis?\ 2144}#
- #{dots\ 2160}#))
- #{tmp\ 2158}#)
+ (apply (lambda (#{dots\ 4915}# #{e\ 4916}#)
+ (#{gen-syntax\ 4866}#
+ #{src\ 4900}#
+ #{e\ 4916}#
+ #{r\ 4902}#
+ #{maps\ 4903}#
+ (lambda (#{x\ 4917}#) #f)
+ #{mod\ 4905}#))
+ #{tmp\ 4912}#)
+ ((lambda (#{tmp\ 4918}#)
+ (if (if #{tmp\ 4918}#
+ (apply (lambda (#{x\ 4919}#
+ #{dots\ 4920}#
+ #{y\ 4921}#)
+ (#{ellipsis?\ 4904}#
+ #{dots\ 4920}#))
+ #{tmp\ 4918}#)
#f)
- (apply (lambda (#{x\ 2162}#
- #{dots\ 2163}#
- #{y\ 2164}#)
- (letrec ((#{f\ 2165}#
- (lambda (#{y\ 2166}#
- #{k\ 2167}#)
- ((lambda (#{tmp\ 2171}#)
- ((lambda (#{tmp\ 2172}#)
- (if (if #{tmp\ 2172}#
- (apply (lambda (#{dots\ 2173}#
- #{y\ 2174}#)
- (#{ellipsis?\ 2144}#
- #{dots\ 2173}#))
- #{tmp\ 2172}#)
+ (apply (lambda (#{x\ 4922}#
+ #{dots\ 4923}#
+ #{y\ 4924}#)
+ (letrec ((#{f\ 4925}#
+ (lambda (#{y\ 4926}#
+ #{k\ 4927}#)
+ ((lambda (#{tmp\ 4931}#)
+ ((lambda (#{tmp\ 4932}#)
+ (if (if #{tmp\ 4932}#
+ (apply (lambda (#{dots\ 4933}#
+ #{y\ 4934}#)
+ (#{ellipsis?\ 4904}#
+ #{dots\ 4933}#))
+ #{tmp\ 4932}#)
#f)
- (apply (lambda (#{dots\ 2175}#
- #{y\ 2176}#)
- (#{f\ 2165}#
- #{y\ 2176}#
- (lambda (#{maps\ 2177}#)
+ (apply (lambda (#{dots\ 4935}#
+ #{y\ 4936}#)
+ (#{f\ 4925}#
+ #{y\ 4936}#
+ (lambda (#{maps\ 4937}#)
(call-with-values
(lambda ()
- (#{k\ 2167}#
+ (#{k\ 4927}#
(cons '()
- #{maps\ 2177}#)))
- (lambda (#{x\ 2178}#
- #{maps\ 2179}#)
- (if (null? (car #{maps\ 2179}#))
+ #{maps\ 4937}#)))
+ (lambda (#{x\ 4938}#
+ #{maps\ 4939}#)
+ (if (null? (car #{maps\ 4939}#))
(syntax-violation
'syntax
"extra ellipsis"
- #{src\ 2140}#)
+ #{src\ 4900}#)
(values
- (#{gen-mappend\ 2108}#
- #{x\ 2178}#
- (car #{maps\ 2179}#))
- (cdr #{maps\ 2179}#))))))))
- #{tmp\ 2172}#)
- ((lambda (#{_\ 2180}#)
+ (#{gen-mappend\ 4868}#
+ #{x\ 4938}#
+ (car #{maps\ 4939}#))
+ (cdr #{maps\ 4939}#))))))))
+ #{tmp\ 4932}#)
+ ((lambda (#{_\ 4940}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{y\ 2166}#
- #{r\ 2142}#
- #{maps\ 2143}#
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{y\ 2181}#
- #{maps\ 2182}#)
+ (#{gen-syntax\ 4866}#
+ #{src\ 4900}#
+ #{y\ 4926}#
+ #{r\ 4902}#
+ #{maps\ 4903}#
+ #{ellipsis?\ 4904}#
+ #{mod\ 4905}#))
+ (lambda (#{y\ 4941}#
+ #{maps\ 4942}#)
(call-with-values
(lambda ()
- (#{k\ 2167}#
- #{maps\ 2182}#))
- (lambda (#{x\ 2183}#
- #{maps\ 2184}#)
+ (#{k\ 4927}#
+ #{maps\ 4942}#))
+ (lambda (#{x\ 4943}#
+ #{maps\ 4944}#)
(values
- (#{gen-append\ 2111}#
- #{x\ 2183}#
- #{y\ 2181}#)
- #{maps\ 2184}#))))))
- #{tmp\ 2171}#)))
+ (#{gen-append\ 4871}#
+ #{x\ 4943}#
+ #{y\ 4941}#)
+ #{maps\ 4944}#))))))
+ #{tmp\ 4931}#)))
($sc-dispatch
- #{tmp\ 2171}#
+ #{tmp\ 4931}#
'(any . any))))
- #{y\ 2166}#))))
- (#{f\ 2165}#
- #{y\ 2164}#
- (lambda (#{maps\ 2168}#)
+ #{y\ 4926}#))))
+ (#{f\ 4925}#
+ #{y\ 4924}#
+ (lambda (#{maps\ 4928}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{x\ 2162}#
- #{r\ 2142}#
+ (#{gen-syntax\ 4866}#
+ #{src\ 4900}#
+ #{x\ 4922}#
+ #{r\ 4902}#
(cons '()
- #{maps\ 2168}#)
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{x\ 2169}#
- #{maps\ 2170}#)
- (if (null? (car #{maps\ 2170}#))
+ #{maps\ 4928}#)
+ #{ellipsis?\ 4904}#
+ #{mod\ 4905}#))
+ (lambda (#{x\ 4929}#
+ #{maps\ 4930}#)
+ (if (null? (car #{maps\ 4930}#))
(syntax-violation
'syntax
"extra ellipsis"
- #{src\ 2140}#)
+ #{src\ 4900}#)
(values
- (#{gen-map\ 2109}#
- #{x\ 2169}#
- (car #{maps\ 2170}#))
- (cdr #{maps\ 2170}#)))))))))
- #{tmp\ 2158}#)
- ((lambda (#{tmp\ 2185}#)
- (if #{tmp\ 2185}#
- (apply (lambda (#{x\ 2186}#
- #{y\ 2187}#)
+ (#{gen-map\ 4869}#
+ #{x\ 4929}#
+ (car #{maps\ 4930}#))
+ (cdr #{maps\ 4930}#)))))))))
+ #{tmp\ 4918}#)
+ ((lambda (#{tmp\ 4945}#)
+ (if #{tmp\ 4945}#
+ (apply (lambda (#{x\ 4946}#
+ #{y\ 4947}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{x\ 2186}#
- #{r\ 2142}#
- #{maps\ 2143}#
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{x\ 2188}#
- #{maps\ 2189}#)
+ (#{gen-syntax\ 4866}#
+ #{src\ 4900}#
+ #{x\ 4946}#
+ #{r\ 4902}#
+ #{maps\ 4903}#
+ #{ellipsis?\ 4904}#
+ #{mod\ 4905}#))
+ (lambda (#{x\ 4948}#
+ #{maps\ 4949}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{y\ 2187}#
- #{r\ 2142}#
- #{maps\ 2189}#
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{y\ 2190}#
- #{maps\ 2191}#)
+ (#{gen-syntax\ 4866}#
+ #{src\ 4900}#
+ #{y\ 4947}#
+ #{r\ 4902}#
+ #{maps\ 4949}#
+ #{ellipsis?\ 4904}#
+ #{mod\ 4905}#))
+ (lambda (#{y\ 4950}#
+ #{maps\ 4951}#)
(values
- (#{gen-cons\ 2110}#
- #{x\ 2188}#
- #{y\ 2190}#)
- #{maps\ 2191}#))))))
- #{tmp\ 2185}#)
- ((lambda (#{tmp\ 2192}#)
- (if #{tmp\ 2192}#
- (apply (lambda (#{e1\ 2193}#
- #{e2\ 2194}#)
+ (#{gen-cons\ 4870}#
+ #{x\ 4948}#
+ #{y\ 4950}#)
+ #{maps\ 4951}#))))))
+ #{tmp\ 4945}#)
+ ((lambda (#{tmp\ 4952}#)
+ (if #{tmp\ 4952}#
+ (apply (lambda (#{e1\ 4953}#
+ #{e2\ 4954}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- (cons #{e1\ 2193}#
- #{e2\ 2194}#)
- #{r\ 2142}#
- #{maps\ 2143}#
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{e\ 2196}#
- #{maps\ 2197}#)
+ (#{gen-syntax\ 4866}#
+ #{src\ 4900}#
+ (cons #{e1\ 4953}#
+ #{e2\ 4954}#)
+ #{r\ 4902}#
+ #{maps\ 4903}#
+ #{ellipsis?\ 4904}#
+ #{mod\ 4905}#))
+ (lambda (#{e\ 4956}#
+ #{maps\ 4957}#)
(values
- (#{gen-vector\ 2112}#
- #{e\ 2196}#)
- #{maps\ 2197}#))))
- #{tmp\ 2192}#)
- ((lambda (#{_\ 2198}#)
+ (#{gen-vector\ 4872}#
+ #{e\ 4956}#)
+ #{maps\ 4957}#))))
+ #{tmp\ 4952}#)
+ ((lambda (#{_\ 4958}#)
(values
(list 'quote
- #{e\ 2141}#)
- #{maps\ 2143}#))
- #{tmp\ 2151}#)))
+ #{e\ 4901}#)
+ #{maps\ 4903}#))
+ #{tmp\ 4911}#)))
($sc-dispatch
- #{tmp\ 2151}#
+ #{tmp\ 4911}#
'#(vector (any . each-any))))))
($sc-dispatch
- #{tmp\ 2151}#
+ #{tmp\ 4911}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 2151}#
+ #{tmp\ 4911}#
'(any any . any)))))
- ($sc-dispatch #{tmp\ 2151}# (quote (any any)))))
- #{e\ 2141}#)))))
- (lambda (#{e\ 2199}#
- #{r\ 2200}#
- #{w\ 2201}#
- #{s\ 2202}#
- #{mod\ 2203}#)
- (let ((#{e\ 2204}#
- (#{source-wrap\ 1326}#
- #{e\ 2199}#
- #{w\ 2201}#
- #{s\ 2202}#
- #{mod\ 2203}#)))
- ((lambda (#{tmp\ 2205}#)
- ((lambda (#{tmp\ 2206}#)
- (if #{tmp\ 2206}#
- (apply (lambda (#{_\ 2207}# #{x\ 2208}#)
+ ($sc-dispatch #{tmp\ 4911}# (quote (any any)))))
+ #{e\ 4901}#)))))
+ (lambda (#{e\ 4959}#
+ #{r\ 4960}#
+ #{w\ 4961}#
+ #{s\ 4962}#
+ #{mod\ 4963}#)
+ (let ((#{e\ 4964}#
+ (#{source-wrap\ 3824}#
+ #{e\ 4959}#
+ #{w\ 4961}#
+ #{s\ 4962}#
+ #{mod\ 4963}#)))
+ ((lambda (#{tmp\ 4965}#)
+ ((lambda (#{tmp\ 4966}#)
+ (if #{tmp\ 4966}#
+ (apply (lambda (#{_\ 4967}# #{x\ 4968}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{e\ 2204}#
- #{x\ 2208}#
- #{r\ 2200}#
+ (#{gen-syntax\ 4866}#
+ #{e\ 4964}#
+ #{x\ 4968}#
+ #{r\ 4960}#
'()
- #{ellipsis?\ 1342}#
- #{mod\ 2203}#))
- (lambda (#{e\ 2209}# #{maps\ 2210}#)
- (#{regen\ 2113}# #{e\ 2209}#))))
- #{tmp\ 2206}#)
- ((lambda (#{_\ 2211}#)
+ #{ellipsis?\ 3839}#
+ #{mod\ 4963}#))
+ (lambda (#{e\ 4969}# #{maps\ 4970}#)
+ (#{regen\ 4873}# #{e\ 4969}#))))
+ #{tmp\ 4966}#)
+ ((lambda (#{_\ 4971}#)
(syntax-violation
'syntax
"bad `syntax' form"
- #{e\ 2204}#))
- #{tmp\ 2205}#)))
- ($sc-dispatch #{tmp\ 2205}# (quote (any any)))))
- #{e\ 2204}#)))))
- (#{global-extend\ 1295}#
+ #{e\ 4964}#))
+ #{tmp\ 4965}#)))
+ ($sc-dispatch #{tmp\ 4965}# (quote (any any)))))
+ #{e\ 4964}#)))))
+ (#{global-extend\ 3793}#
'core
'lambda
- (lambda (#{e\ 2212}#
- #{r\ 2213}#
- #{w\ 2214}#
- #{s\ 2215}#
- #{mod\ 2216}#)
- ((lambda (#{tmp\ 2217}#)
- ((lambda (#{tmp\ 2218}#)
- (if #{tmp\ 2218}#
- (apply (lambda (#{_\ 2219}# #{c\ 2220}#)
- (#{chi-lambda-clause\ 1338}#
- (#{source-wrap\ 1326}#
- #{e\ 2212}#
- #{w\ 2214}#
- #{s\ 2215}#
- #{mod\ 2216}#)
- #f
- #{c\ 2220}#
- #{r\ 2213}#
- #{w\ 2214}#
- #{mod\ 2216}#
- (lambda (#{names\ 2221}#
- #{vars\ 2222}#
- #{docstring\ 2223}#
- #{body\ 2224}#)
- (#{build-lambda\ 1273}#
- #{s\ 2215}#
- #{names\ 2221}#
- #{vars\ 2222}#
- #{docstring\ 2223}#
- #{body\ 2224}#))))
- #{tmp\ 2218}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2217}#)))
- ($sc-dispatch #{tmp\ 2217}# (quote (any . any)))))
- #{e\ 2212}#)))
- (#{global-extend\ 1295}#
+ (lambda (#{e\ 4972}#
+ #{r\ 4973}#
+ #{w\ 4974}#
+ #{s\ 4975}#
+ #{mod\ 4976}#)
+ ((lambda (#{tmp\ 4977}#)
+ ((lambda (#{tmp\ 4978}#)
+ (if (if #{tmp\ 4978}#
+ (apply (lambda (#{_\ 4979}#
+ #{args\ 4980}#
+ #{docstring\ 4981}#
+ #{e1\ 4982}#
+ #{e2\ 4983}#)
+ (string? (syntax->datum #{docstring\ 4981}#)))
+ #{tmp\ 4978}#)
+ #f)
+ (apply (lambda (#{_\ 4984}#
+ #{args\ 4985}#
+ #{docstring\ 4986}#
+ #{e1\ 4987}#
+ #{e2\ 4988}#)
+ (call-with-values
+ (lambda ()
+ (#{lambda-formals\ 3840}# #{args\ 4985}#))
+ (lambda (#{req\ 4989}#
+ #{opt\ 4990}#
+ #{rest\ 4991}#
+ #{kw\ 4992}#)
+ (#{chi-simple-lambda\ 3841}#
+ #{e\ 4972}#
+ #{r\ 4973}#
+ #{w\ 4974}#
+ #{s\ 4975}#
+ #{mod\ 4976}#
+ #{req\ 4989}#
+ #{rest\ 4991}#
+ (syntax->datum #{docstring\ 4986}#)
+ (cons #{e1\ 4987}# #{e2\ 4988}#)))))
+ #{tmp\ 4978}#)
+ ((lambda (#{tmp\ 4994}#)
+ (if #{tmp\ 4994}#
+ (apply (lambda (#{_\ 4995}#
+ #{args\ 4996}#
+ #{e1\ 4997}#
+ #{e2\ 4998}#)
+ (call-with-values
+ (lambda ()
+ (#{lambda-formals\ 3840}# #{args\ 4996}#))
+ (lambda (#{req\ 4999}#
+ #{opt\ 5000}#
+ #{rest\ 5001}#
+ #{kw\ 5002}#)
+ (#{chi-simple-lambda\ 3841}#
+ #{e\ 4972}#
+ #{r\ 4973}#
+ #{w\ 4974}#
+ #{s\ 4975}#
+ #{mod\ 4976}#
+ #{req\ 4999}#
+ #{rest\ 5001}#
+ #f
+ (cons #{e1\ 4997}# #{e2\ 4998}#)))))
+ #{tmp\ 4994}#)
+ ((lambda (#{_\ 5004}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda"
+ #{e\ 4972}#))
+ #{tmp\ 4977}#)))
+ ($sc-dispatch
+ #{tmp\ 4977}#
+ '(any any any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 4977}#
+ '(any any any any . each-any))))
+ #{e\ 4972}#)))
+ (#{global-extend\ 3793}#
+ 'core
+ 'lambda*
+ (lambda (#{e\ 5005}#
+ #{r\ 5006}#
+ #{w\ 5007}#
+ #{s\ 5008}#
+ #{mod\ 5009}#)
+ ((lambda (#{tmp\ 5010}#)
+ ((lambda (#{tmp\ 5011}#)
+ (if #{tmp\ 5011}#
+ (apply (lambda (#{_\ 5012}#
+ #{args\ 5013}#
+ #{e1\ 5014}#
+ #{e2\ 5015}#)
+ (call-with-values
+ (lambda ()
+ (#{chi-lambda-case\ 3843}#
+ #{e\ 5005}#
+ #{r\ 5006}#
+ #{w\ 5007}#
+ #{s\ 5008}#
+ #{mod\ 5009}#
+ #{lambda*-formals\ 3842}#
+ (list (cons #{args\ 5013}#
+ (cons #{e1\ 5014}#
+ #{e2\ 5015}#)))))
+ (lambda (#{docstring\ 5017}# #{lcase\ 5018}#)
+ (#{build-case-lambda\ 3770}#
+ #{s\ 5008}#
+ #{docstring\ 5017}#
+ #{lcase\ 5018}#))))
+ #{tmp\ 5011}#)
+ ((lambda (#{_\ 5019}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda*"
+ #{e\ 5005}#))
+ #{tmp\ 5010}#)))
+ ($sc-dispatch
+ #{tmp\ 5010}#
+ '(any any any . each-any))))
+ #{e\ 5005}#)))
+ (#{global-extend\ 3793}#
+ 'core
+ 'case-lambda
+ (lambda (#{e\ 5020}#
+ #{r\ 5021}#
+ #{w\ 5022}#
+ #{s\ 5023}#
+ #{mod\ 5024}#)
+ ((lambda (#{tmp\ 5025}#)
+ ((lambda (#{tmp\ 5026}#)
+ (if #{tmp\ 5026}#
+ (apply (lambda (#{_\ 5027}#
+ #{args\ 5028}#
+ #{e1\ 5029}#
+ #{e2\ 5030}#
+ #{args*\ 5031}#
+ #{e1*\ 5032}#
+ #{e2*\ 5033}#)
+ (call-with-values
+ (lambda ()
+ (#{chi-lambda-case\ 3843}#
+ #{e\ 5020}#
+ #{r\ 5021}#
+ #{w\ 5022}#
+ #{s\ 5023}#
+ #{mod\ 5024}#
+ #{lambda-formals\ 3840}#
+ (cons (cons #{args\ 5028}#
+ (cons #{e1\ 5029}# #{e2\ 5030}#))
+ (map (lambda (#{tmp\ 5037}#
+ #{tmp\ 5036}#
+ #{tmp\ 5035}#)
+ (cons #{tmp\ 5035}#
+ (cons #{tmp\ 5036}#
+ #{tmp\ 5037}#)))
+ #{e2*\ 5033}#
+ #{e1*\ 5032}#
+ #{args*\ 5031}#))))
+ (lambda (#{docstring\ 5039}# #{lcase\ 5040}#)
+ (#{build-case-lambda\ 3770}#
+ #{s\ 5023}#
+ #{docstring\ 5039}#
+ #{lcase\ 5040}#))))
+ #{tmp\ 5026}#)
+ ((lambda (#{_\ 5041}#)
+ (syntax-violation
+ 'case-lambda
+ "bad case-lambda"
+ #{e\ 5020}#))
+ #{tmp\ 5025}#)))
+ ($sc-dispatch
+ #{tmp\ 5025}#
+ '(any (any any . each-any)
+ .
+ #(each (any any . each-any))))))
+ #{e\ 5020}#)))
+ (#{global-extend\ 3793}#
+ 'core
+ 'case-lambda*
+ (lambda (#{e\ 5042}#
+ #{r\ 5043}#
+ #{w\ 5044}#
+ #{s\ 5045}#
+ #{mod\ 5046}#)
+ ((lambda (#{tmp\ 5047}#)
+ ((lambda (#{tmp\ 5048}#)
+ (if #{tmp\ 5048}#
+ (apply (lambda (#{_\ 5049}#
+ #{args\ 5050}#
+ #{e1\ 5051}#
+ #{e2\ 5052}#
+ #{args*\ 5053}#
+ #{e1*\ 5054}#
+ #{e2*\ 5055}#)
+ (call-with-values
+ (lambda ()
+ (#{chi-lambda-case\ 3843}#
+ #{e\ 5042}#
+ #{r\ 5043}#
+ #{w\ 5044}#
+ #{s\ 5045}#
+ #{mod\ 5046}#
+ #{lambda*-formals\ 3842}#
+ (cons (cons #{args\ 5050}#
+ (cons #{e1\ 5051}# #{e2\ 5052}#))
+ (map (lambda (#{tmp\ 5059}#
+ #{tmp\ 5058}#
+ #{tmp\ 5057}#)
+ (cons #{tmp\ 5057}#
+ (cons #{tmp\ 5058}#
+ #{tmp\ 5059}#)))
+ #{e2*\ 5055}#
+ #{e1*\ 5054}#
+ #{args*\ 5053}#))))
+ (lambda (#{docstring\ 5061}# #{lcase\ 5062}#)
+ (#{build-case-lambda\ 3770}#
+ #{s\ 5045}#
+ #{docstring\ 5061}#
+ #{lcase\ 5062}#))))
+ #{tmp\ 5048}#)
+ ((lambda (#{_\ 5063}#)
+ (syntax-violation
+ 'case-lambda
+ "bad case-lambda*"
+ #{e\ 5042}#))
+ #{tmp\ 5047}#)))
+ ($sc-dispatch
+ #{tmp\ 5047}#
+ '(any (any any . each-any)
+ .
+ #(each (any any . each-any))))))
+ #{e\ 5042}#)))
+ (#{global-extend\ 3793}#
'core
'let
- (letrec ((#{chi-let\ 2225}#
- (lambda (#{e\ 2226}#
- #{r\ 2227}#
- #{w\ 2228}#
- #{s\ 2229}#
- #{mod\ 2230}#
- #{constructor\ 2231}#
- #{ids\ 2232}#
- #{vals\ 2233}#
- #{exps\ 2234}#)
- (if (not (#{valid-bound-ids?\ 1322}# #{ids\ 2232}#))
+ (letrec ((#{chi-let\ 5064}#
+ (lambda (#{e\ 5065}#
+ #{r\ 5066}#
+ #{w\ 5067}#
+ #{s\ 5068}#
+ #{mod\ 5069}#
+ #{constructor\ 5070}#
+ #{ids\ 5071}#
+ #{vals\ 5072}#
+ #{exps\ 5073}#)
+ (if (not (#{valid-bound-ids?\ 3820}# #{ids\ 5071}#))
(syntax-violation
'let
"duplicate bound variable"
- #{e\ 2226}#)
- (let ((#{labels\ 2235}#
- (#{gen-labels\ 1303}# #{ids\ 2232}#))
- (#{new-vars\ 2236}#
- (map #{gen-var\ 1344}# #{ids\ 2232}#)))
- (let ((#{nw\ 2237}#
- (#{make-binding-wrap\ 1314}#
- #{ids\ 2232}#
- #{labels\ 2235}#
- #{w\ 2228}#))
- (#{nr\ 2238}#
- (#{extend-var-env\ 1292}#
- #{labels\ 2235}#
- #{new-vars\ 2236}#
- #{r\ 2227}#)))
- (#{constructor\ 2231}#
- #{s\ 2229}#
- (map syntax->datum #{ids\ 2232}#)
- #{new-vars\ 2236}#
- (map (lambda (#{x\ 2239}#)
- (#{chi\ 1333}#
- #{x\ 2239}#
- #{r\ 2227}#
- #{w\ 2228}#
- #{mod\ 2230}#))
- #{vals\ 2233}#)
- (#{chi-body\ 1337}#
- #{exps\ 2234}#
- (#{source-wrap\ 1326}#
- #{e\ 2226}#
- #{nw\ 2237}#
- #{s\ 2229}#
- #{mod\ 2230}#)
- #{nr\ 2238}#
- #{nw\ 2237}#
- #{mod\ 2230}#))))))))
- (lambda (#{e\ 2240}#
- #{r\ 2241}#
- #{w\ 2242}#
- #{s\ 2243}#
- #{mod\ 2244}#)
- ((lambda (#{tmp\ 2245}#)
- ((lambda (#{tmp\ 2246}#)
- (if (if #{tmp\ 2246}#
- (apply (lambda (#{_\ 2247}#
- #{id\ 2248}#
- #{val\ 2249}#
- #{e1\ 2250}#
- #{e2\ 2251}#)
- (and-map #{id?\ 1297}# #{id\ 2248}#))
- #{tmp\ 2246}#)
+ #{e\ 5065}#)
+ (let ((#{labels\ 5074}#
+ (#{gen-labels\ 3801}# #{ids\ 5071}#))
+ (#{new-vars\ 5075}#
+ (map #{gen-var\ 3845}# #{ids\ 5071}#)))
+ (let ((#{nw\ 5076}#
+ (#{make-binding-wrap\ 3812}#
+ #{ids\ 5071}#
+ #{labels\ 5074}#
+ #{w\ 5067}#))
+ (#{nr\ 5077}#
+ (#{extend-var-env\ 3790}#
+ #{labels\ 5074}#
+ #{new-vars\ 5075}#
+ #{r\ 5066}#)))
+ (#{constructor\ 5070}#
+ #{s\ 5068}#
+ (map syntax->datum #{ids\ 5071}#)
+ #{new-vars\ 5075}#
+ (map (lambda (#{x\ 5078}#)
+ (#{chi\ 3831}#
+ #{x\ 5078}#
+ #{r\ 5066}#
+ #{w\ 5067}#
+ #{mod\ 5069}#))
+ #{vals\ 5072}#)
+ (#{chi-body\ 3835}#
+ #{exps\ 5073}#
+ (#{source-wrap\ 3824}#
+ #{e\ 5065}#
+ #{nw\ 5076}#
+ #{s\ 5068}#
+ #{mod\ 5069}#)
+ #{nr\ 5077}#
+ #{nw\ 5076}#
+ #{mod\ 5069}#))))))))
+ (lambda (#{e\ 5079}#
+ #{r\ 5080}#
+ #{w\ 5081}#
+ #{s\ 5082}#
+ #{mod\ 5083}#)
+ ((lambda (#{tmp\ 5084}#)
+ ((lambda (#{tmp\ 5085}#)
+ (if (if #{tmp\ 5085}#
+ (apply (lambda (#{_\ 5086}#
+ #{id\ 5087}#
+ #{val\ 5088}#
+ #{e1\ 5089}#
+ #{e2\ 5090}#)
+ (and-map #{id?\ 3795}# #{id\ 5087}#))
+ #{tmp\ 5085}#)
#f)
- (apply (lambda (#{_\ 2253}#
- #{id\ 2254}#
- #{val\ 2255}#
- #{e1\ 2256}#
- #{e2\ 2257}#)
- (#{chi-let\ 2225}#
- #{e\ 2240}#
- #{r\ 2241}#
- #{w\ 2242}#
- #{s\ 2243}#
- #{mod\ 2244}#
- #{build-let\ 1277}#
- #{id\ 2254}#
- #{val\ 2255}#
- (cons #{e1\ 2256}# #{e2\ 2257}#)))
- #{tmp\ 2246}#)
- ((lambda (#{tmp\ 2261}#)
- (if (if #{tmp\ 2261}#
- (apply (lambda (#{_\ 2262}#
- #{f\ 2263}#
- #{id\ 2264}#
- #{val\ 2265}#
- #{e1\ 2266}#
- #{e2\ 2267}#)
- (if (#{id?\ 1297}# #{f\ 2263}#)
- (and-map #{id?\ 1297}# #{id\ 2264}#)
+ (apply (lambda (#{_\ 5092}#
+ #{id\ 5093}#
+ #{val\ 5094}#
+ #{e1\ 5095}#
+ #{e2\ 5096}#)
+ (#{chi-let\ 5064}#
+ #{e\ 5079}#
+ #{r\ 5080}#
+ #{w\ 5081}#
+ #{s\ 5082}#
+ #{mod\ 5083}#
+ #{build-let\ 3775}#
+ #{id\ 5093}#
+ #{val\ 5094}#
+ (cons #{e1\ 5095}# #{e2\ 5096}#)))
+ #{tmp\ 5085}#)
+ ((lambda (#{tmp\ 5100}#)
+ (if (if #{tmp\ 5100}#
+ (apply (lambda (#{_\ 5101}#
+ #{f\ 5102}#
+ #{id\ 5103}#
+ #{val\ 5104}#
+ #{e1\ 5105}#
+ #{e2\ 5106}#)
+ (if (#{id?\ 3795}# #{f\ 5102}#)
+ (and-map #{id?\ 3795}# #{id\ 5103}#)
#f))
- #{tmp\ 2261}#)
+ #{tmp\ 5100}#)
#f)
- (apply (lambda (#{_\ 2269}#
- #{f\ 2270}#
- #{id\ 2271}#
- #{val\ 2272}#
- #{e1\ 2273}#
- #{e2\ 2274}#)
- (#{chi-let\ 2225}#
- #{e\ 2240}#
- #{r\ 2241}#
- #{w\ 2242}#
- #{s\ 2243}#
- #{mod\ 2244}#
- #{build-named-let\ 1278}#
- (cons #{f\ 2270}# #{id\ 2271}#)
- #{val\ 2272}#
- (cons #{e1\ 2273}# #{e2\ 2274}#)))
- #{tmp\ 2261}#)
- ((lambda (#{_\ 2278}#)
+ (apply (lambda (#{_\ 5108}#
+ #{f\ 5109}#
+ #{id\ 5110}#
+ #{val\ 5111}#
+ #{e1\ 5112}#
+ #{e2\ 5113}#)
+ (#{chi-let\ 5064}#
+ #{e\ 5079}#
+ #{r\ 5080}#
+ #{w\ 5081}#
+ #{s\ 5082}#
+ #{mod\ 5083}#
+ #{build-named-let\ 3776}#
+ (cons #{f\ 5109}# #{id\ 5110}#)
+ #{val\ 5111}#
+ (cons #{e1\ 5112}# #{e2\ 5113}#)))
+ #{tmp\ 5100}#)
+ ((lambda (#{_\ 5117}#)
(syntax-violation
'let
"bad let"
- (#{source-wrap\ 1326}#
- #{e\ 2240}#
- #{w\ 2242}#
- #{s\ 2243}#
- #{mod\ 2244}#)))
- #{tmp\ 2245}#)))
+ (#{source-wrap\ 3824}#
+ #{e\ 5079}#
+ #{w\ 5081}#
+ #{s\ 5082}#
+ #{mod\ 5083}#)))
+ #{tmp\ 5084}#)))
($sc-dispatch
- #{tmp\ 2245}#
+ #{tmp\ 5084}#
'(any any #(each (any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 2245}#
+ #{tmp\ 5084}#
'(any #(each (any any)) any . each-any))))
- #{e\ 2240}#))))
- (#{global-extend\ 1295}#
+ #{e\ 5079}#))))
+ (#{global-extend\ 3793}#
'core
'letrec
- (lambda (#{e\ 2279}#
- #{r\ 2280}#
- #{w\ 2281}#
- #{s\ 2282}#
- #{mod\ 2283}#)
- ((lambda (#{tmp\ 2284}#)
- ((lambda (#{tmp\ 2285}#)
- (if (if #{tmp\ 2285}#
- (apply (lambda (#{_\ 2286}#
- #{id\ 2287}#
- #{val\ 2288}#
- #{e1\ 2289}#
- #{e2\ 2290}#)
- (and-map #{id?\ 1297}# #{id\ 2287}#))
- #{tmp\ 2285}#)
+ (lambda (#{e\ 5118}#
+ #{r\ 5119}#
+ #{w\ 5120}#
+ #{s\ 5121}#
+ #{mod\ 5122}#)
+ ((lambda (#{tmp\ 5123}#)
+ ((lambda (#{tmp\ 5124}#)
+ (if (if #{tmp\ 5124}#
+ (apply (lambda (#{_\ 5125}#
+ #{id\ 5126}#
+ #{val\ 5127}#
+ #{e1\ 5128}#
+ #{e2\ 5129}#)
+ (and-map #{id?\ 3795}# #{id\ 5126}#))
+ #{tmp\ 5124}#)
#f)
- (apply (lambda (#{_\ 2292}#
- #{id\ 2293}#
- #{val\ 2294}#
- #{e1\ 2295}#
- #{e2\ 2296}#)
- (let ((#{ids\ 2297}# #{id\ 2293}#))
- (if (not (#{valid-bound-ids?\ 1322}#
- #{ids\ 2297}#))
+ (apply (lambda (#{_\ 5131}#
+ #{id\ 5132}#
+ #{val\ 5133}#
+ #{e1\ 5134}#
+ #{e2\ 5135}#)
+ (let ((#{ids\ 5136}# #{id\ 5132}#))
+ (if (not (#{valid-bound-ids?\ 3820}#
+ #{ids\ 5136}#))
(syntax-violation
'letrec
"duplicate bound variable"
- #{e\ 2279}#)
- (let ((#{labels\ 2299}#
- (#{gen-labels\ 1303}# #{ids\ 2297}#))
- (#{new-vars\ 2300}#
- (map #{gen-var\ 1344}# #{ids\ 2297}#)))
- (let ((#{w\ 2301}#
- (#{make-binding-wrap\ 1314}#
- #{ids\ 2297}#
- #{labels\ 2299}#
- #{w\ 2281}#))
- (#{r\ 2302}#
- (#{extend-var-env\ 1292}#
- #{labels\ 2299}#
- #{new-vars\ 2300}#
- #{r\ 2280}#)))
- (#{build-letrec\ 1279}#
- #{s\ 2282}#
- (map syntax->datum #{ids\ 2297}#)
- #{new-vars\ 2300}#
- (map (lambda (#{x\ 2303}#)
- (#{chi\ 1333}#
- #{x\ 2303}#
- #{r\ 2302}#
- #{w\ 2301}#
- #{mod\ 2283}#))
- #{val\ 2294}#)
- (#{chi-body\ 1337}#
- (cons #{e1\ 2295}# #{e2\ 2296}#)
- (#{source-wrap\ 1326}#
- #{e\ 2279}#
- #{w\ 2301}#
- #{s\ 2282}#
- #{mod\ 2283}#)
- #{r\ 2302}#
- #{w\ 2301}#
- #{mod\ 2283}#)))))))
- #{tmp\ 2285}#)
- ((lambda (#{_\ 2306}#)
+ #{e\ 5118}#)
+ (let ((#{labels\ 5138}#
+ (#{gen-labels\ 3801}# #{ids\ 5136}#))
+ (#{new-vars\ 5139}#
+ (map #{gen-var\ 3845}# #{ids\ 5136}#)))
+ (let ((#{w\ 5140}#
+ (#{make-binding-wrap\ 3812}#
+ #{ids\ 5136}#
+ #{labels\ 5138}#
+ #{w\ 5120}#))
+ (#{r\ 5141}#
+ (#{extend-var-env\ 3790}#
+ #{labels\ 5138}#
+ #{new-vars\ 5139}#
+ #{r\ 5119}#)))
+ (#{build-letrec\ 3777}#
+ #{s\ 5121}#
+ (map syntax->datum #{ids\ 5136}#)
+ #{new-vars\ 5139}#
+ (map (lambda (#{x\ 5142}#)
+ (#{chi\ 3831}#
+ #{x\ 5142}#
+ #{r\ 5141}#
+ #{w\ 5140}#
+ #{mod\ 5122}#))
+ #{val\ 5133}#)
+ (#{chi-body\ 3835}#
+ (cons #{e1\ 5134}# #{e2\ 5135}#)
+ (#{source-wrap\ 3824}#
+ #{e\ 5118}#
+ #{w\ 5140}#
+ #{s\ 5121}#
+ #{mod\ 5122}#)
+ #{r\ 5141}#
+ #{w\ 5140}#
+ #{mod\ 5122}#)))))))
+ #{tmp\ 5124}#)
+ ((lambda (#{_\ 5145}#)
(syntax-violation
'letrec
"bad letrec"
- (#{source-wrap\ 1326}#
- #{e\ 2279}#
- #{w\ 2281}#
- #{s\ 2282}#
- #{mod\ 2283}#)))
- #{tmp\ 2284}#)))
+ (#{source-wrap\ 3824}#
+ #{e\ 5118}#
+ #{w\ 5120}#
+ #{s\ 5121}#
+ #{mod\ 5122}#)))
+ #{tmp\ 5123}#)))
($sc-dispatch
- #{tmp\ 2284}#
+ #{tmp\ 5123}#
'(any #(each (any any)) any . each-any))))
- #{e\ 2279}#)))
- (#{global-extend\ 1295}#
+ #{e\ 5118}#)))
+ (#{global-extend\ 3793}#
'core
'set!
- (lambda (#{e\ 2307}#
- #{r\ 2308}#
- #{w\ 2309}#
- #{s\ 2310}#
- #{mod\ 2311}#)
- ((lambda (#{tmp\ 2312}#)
- ((lambda (#{tmp\ 2313}#)
- (if (if #{tmp\ 2313}#
- (apply (lambda (#{_\ 2314}# #{id\ 2315}# #{val\ 2316}#)
- (#{id?\ 1297}# #{id\ 2315}#))
- #{tmp\ 2313}#)
+ (lambda (#{e\ 5146}#
+ #{r\ 5147}#
+ #{w\ 5148}#
+ #{s\ 5149}#
+ #{mod\ 5150}#)
+ ((lambda (#{tmp\ 5151}#)
+ ((lambda (#{tmp\ 5152}#)
+ (if (if #{tmp\ 5152}#
+ (apply (lambda (#{_\ 5153}# #{id\ 5154}# #{val\ 5155}#)
+ (#{id?\ 3795}# #{id\ 5154}#))
+ #{tmp\ 5152}#)
#f)
- (apply (lambda (#{_\ 2317}# #{id\ 2318}# #{val\ 2319}#)
- (let ((#{val\ 2320}#
- (#{chi\ 1333}#
- #{val\ 2319}#
- #{r\ 2308}#
- #{w\ 2309}#
- #{mod\ 2311}#))
- (#{n\ 2321}#
- (#{id-var-name\ 1319}#
- #{id\ 2318}#
- #{w\ 2309}#)))
- (let ((#{b\ 2322}#
- (#{lookup\ 1294}#
- #{n\ 2321}#
- #{r\ 2308}#
- #{mod\ 2311}#)))
- (let ((#{atom-key\ 2323}#
- (#{binding-type\ 1289}# #{b\ 2322}#)))
- (if (memv #{atom-key\ 2323}#
+ (apply (lambda (#{_\ 5156}# #{id\ 5157}# #{val\ 5158}#)
+ (let ((#{val\ 5159}#
+ (#{chi\ 3831}#
+ #{val\ 5158}#
+ #{r\ 5147}#
+ #{w\ 5148}#
+ #{mod\ 5150}#))
+ (#{n\ 5160}#
+ (#{id-var-name\ 3817}#
+ #{id\ 5157}#
+ #{w\ 5148}#)))
+ (let ((#{b\ 5161}#
+ (#{lookup\ 3792}#
+ #{n\ 5160}#
+ #{r\ 5147}#
+ #{mod\ 5150}#)))
+ (let ((#{atom-key\ 5162}#
+ (#{binding-type\ 3787}# #{b\ 5161}#)))
+ (if (memv #{atom-key\ 5162}#
'(lexical))
- (#{build-lexical-assignment\ 1267}#
- #{s\ 2310}#
- (syntax->datum #{id\ 2318}#)
- (#{binding-value\ 1290}# #{b\ 2322}#)
- #{val\ 2320}#)
- (if (memv #{atom-key\ 2323}#
+ (#{build-lexical-assignment\ 3763}#
+ #{s\ 5149}#
+ (syntax->datum #{id\ 5157}#)
+ (#{binding-value\ 3788}# #{b\ 5161}#)
+ #{val\ 5159}#)
+ (if (memv #{atom-key\ 5162}#
'(global))
- (#{build-global-assignment\ 1270}#
- #{s\ 2310}#
- #{n\ 2321}#
- #{val\ 2320}#
- #{mod\ 2311}#)
- (if (memv #{atom-key\ 2323}#
+ (#{build-global-assignment\ 3766}#
+ #{s\ 5149}#
+ #{n\ 5160}#
+ #{val\ 5159}#
+ #{mod\ 5150}#)
+ (if (memv #{atom-key\ 5162}#
'(displaced-lexical))
(syntax-violation
'set!
"identifier out of context"
- (#{wrap\ 1325}#
- #{id\ 2318}#
- #{w\ 2309}#
- #{mod\ 2311}#))
+ (#{wrap\ 3823}#
+ #{id\ 5157}#
+ #{w\ 5148}#
+ #{mod\ 5150}#))
(syntax-violation
'set!
"bad set!"
- (#{source-wrap\ 1326}#
- #{e\ 2307}#
- #{w\ 2309}#
- #{s\ 2310}#
- #{mod\ 2311}#)))))))))
- #{tmp\ 2313}#)
- ((lambda (#{tmp\ 2324}#)
- (if #{tmp\ 2324}#
- (apply (lambda (#{_\ 2325}#
- #{head\ 2326}#
- #{tail\ 2327}#
- #{val\ 2328}#)
+ (#{source-wrap\ 3824}#
+ #{e\ 5146}#
+ #{w\ 5148}#
+ #{s\ 5149}#
+ #{mod\ 5150}#)))))))))
+ #{tmp\ 5152}#)
+ ((lambda (#{tmp\ 5163}#)
+ (if #{tmp\ 5163}#
+ (apply (lambda (#{_\ 5164}#
+ #{head\ 5165}#
+ #{tail\ 5166}#
+ #{val\ 5167}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{head\ 2326}#
- #{r\ 2308}#
+ (#{syntax-type\ 3829}#
+ #{head\ 5165}#
+ #{r\ 5147}#
'(())
#f
#f
- #{mod\ 2311}#
+ #{mod\ 5150}#
#t))
- (lambda (#{type\ 2329}#
- #{value\ 2330}#
- #{ee\ 2331}#
- #{ww\ 2332}#
- #{ss\ 2333}#
- #{modmod\ 2334}#)
- (if (memv #{type\ 2329}#
+ (lambda (#{type\ 5168}#
+ #{value\ 5169}#
+ #{ee\ 5170}#
+ #{ww\ 5171}#
+ #{ss\ 5172}#
+ #{modmod\ 5173}#)
+ (if (memv #{type\ 5168}#
'(module-ref))
- (let ((#{val\ 2335}#
- (#{chi\ 1333}#
- #{val\ 2328}#
- #{r\ 2308}#
- #{w\ 2309}#
- #{mod\ 2311}#)))
+ (let ((#{val\ 5174}#
+ (#{chi\ 3831}#
+ #{val\ 5167}#
+ #{r\ 5147}#
+ #{w\ 5148}#
+ #{mod\ 5150}#)))
(call-with-values
(lambda ()
- (#{value\ 2330}#
- (cons #{head\ 2326}#
- #{tail\ 2327}#)))
- (lambda (#{id\ 2337}# #{mod\ 2338}#)
- (#{build-global-assignment\ 1270}#
- #{s\ 2310}#
- #{id\ 2337}#
- #{val\ 2335}#
- #{mod\ 2338}#))))
- (#{build-application\ 1264}#
- #{s\ 2310}#
- (#{chi\ 1333}#
+ (#{value\ 5169}#
+ (cons #{head\ 5165}#
+ #{tail\ 5166}#)))
+ (lambda (#{id\ 5176}# #{mod\ 5177}#)
+ (#{build-global-assignment\ 3766}#
+ #{s\ 5149}#
+ #{id\ 5176}#
+ #{val\ 5174}#
+ #{mod\ 5177}#))))
+ (#{build-application\ 3760}#
+ #{s\ 5149}#
+ (#{chi\ 3831}#
(list '#(syntax-object
setter
((top)
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
((top) (top))
("i" "i")))
(hygiene guile))
- #{head\ 2326}#)
- #{r\ 2308}#
- #{w\ 2309}#
- #{mod\ 2311}#)
- (map (lambda (#{e\ 2339}#)
- (#{chi\ 1333}#
- #{e\ 2339}#
- #{r\ 2308}#
- #{w\ 2309}#
- #{mod\ 2311}#))
+ #{head\ 5165}#)
+ #{r\ 5147}#
+ #{w\ 5148}#
+ #{mod\ 5150}#)
+ (map (lambda (#{e\ 5178}#)
+ (#{chi\ 3831}#
+ #{e\ 5178}#
+ #{r\ 5147}#
+ #{w\ 5148}#
+ #{mod\ 5150}#))
(append
- #{tail\ 2327}#
- (list #{val\ 2328}#))))))))
- #{tmp\ 2324}#)
- ((lambda (#{_\ 2341}#)
+ #{tail\ 5166}#
+ (list #{val\ 5167}#))))))))
+ #{tmp\ 5163}#)
+ ((lambda (#{_\ 5180}#)
(syntax-violation
'set!
"bad set!"
- (#{source-wrap\ 1326}#
- #{e\ 2307}#
- #{w\ 2309}#
- #{s\ 2310}#
- #{mod\ 2311}#)))
- #{tmp\ 2312}#)))
+ (#{source-wrap\ 3824}#
+ #{e\ 5146}#
+ #{w\ 5148}#
+ #{s\ 5149}#
+ #{mod\ 5150}#)))
+ #{tmp\ 5151}#)))
($sc-dispatch
- #{tmp\ 2312}#
+ #{tmp\ 5151}#
'(any (any . each-any) any)))))
($sc-dispatch
- #{tmp\ 2312}#
+ #{tmp\ 5151}#
'(any any any))))
- #{e\ 2307}#)))
- (#{global-extend\ 1295}#
+ #{e\ 5146}#)))
+ (#{global-extend\ 3793}#
'module-ref
'@
- (lambda (#{e\ 2342}#)
- ((lambda (#{tmp\ 2343}#)
- ((lambda (#{tmp\ 2344}#)
- (if (if #{tmp\ 2344}#
- (apply (lambda (#{_\ 2345}# #{mod\ 2346}# #{id\ 2347}#)
- (if (and-map #{id?\ 1297}# #{mod\ 2346}#)
- (#{id?\ 1297}# #{id\ 2347}#)
+ (lambda (#{e\ 5181}#)
+ ((lambda (#{tmp\ 5182}#)
+ ((lambda (#{tmp\ 5183}#)
+ (if (if #{tmp\ 5183}#
+ (apply (lambda (#{_\ 5184}# #{mod\ 5185}# #{id\ 5186}#)
+ (if (and-map #{id?\ 3795}# #{mod\ 5185}#)
+ (#{id?\ 3795}# #{id\ 5186}#)
#f))
- #{tmp\ 2344}#)
+ #{tmp\ 5183}#)
#f)
- (apply (lambda (#{_\ 2349}# #{mod\ 2350}# #{id\ 2351}#)
+ (apply (lambda (#{_\ 5188}# #{mod\ 5189}# #{id\ 5190}#)
(values
- (syntax->datum #{id\ 2351}#)
+ (syntax->datum #{id\ 5190}#)
(syntax->datum
(cons '#(syntax-object
public
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
((top) (top))
("i" "i")))
(hygiene guile))
- #{mod\ 2350}#))))
- #{tmp\ 2344}#)
+ #{mod\ 5189}#))))
+ #{tmp\ 5183}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2343}#)))
+ #{tmp\ 5182}#)))
($sc-dispatch
- #{tmp\ 2343}#
+ #{tmp\ 5182}#
'(any each-any any))))
- #{e\ 2342}#)))
- (#{global-extend\ 1295}#
+ #{e\ 5181}#)))
+ (#{global-extend\ 3793}#
'module-ref
'@@
- (lambda (#{e\ 2353}#)
- ((lambda (#{tmp\ 2354}#)
- ((lambda (#{tmp\ 2355}#)
- (if (if #{tmp\ 2355}#
- (apply (lambda (#{_\ 2356}# #{mod\ 2357}# #{id\ 2358}#)
- (if (and-map #{id?\ 1297}# #{mod\ 2357}#)
- (#{id?\ 1297}# #{id\ 2358}#)
+ (lambda (#{e\ 5192}#)
+ ((lambda (#{tmp\ 5193}#)
+ ((lambda (#{tmp\ 5194}#)
+ (if (if #{tmp\ 5194}#
+ (apply (lambda (#{_\ 5195}# #{mod\ 5196}# #{id\ 5197}#)
+ (if (and-map #{id?\ 3795}# #{mod\ 5196}#)
+ (#{id?\ 3795}# #{id\ 5197}#)
#f))
- #{tmp\ 2355}#)
+ #{tmp\ 5194}#)
#f)
- (apply (lambda (#{_\ 2360}# #{mod\ 2361}# #{id\ 2362}#)
+ (apply (lambda (#{_\ 5199}# #{mod\ 5200}# #{id\ 5201}#)
(values
- (syntax->datum #{id\ 2362}#)
+ (syntax->datum #{id\ 5201}#)
(syntax->datum
(cons '#(syntax-object
private
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
((top) (top))
("i" "i")))
(hygiene guile))
- #{mod\ 2361}#))))
- #{tmp\ 2355}#)
+ #{mod\ 5200}#))))
+ #{tmp\ 5194}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2354}#)))
+ #{tmp\ 5193}#)))
($sc-dispatch
- #{tmp\ 2354}#
+ #{tmp\ 5193}#
'(any each-any any))))
- #{e\ 2353}#)))
- (#{global-extend\ 1295}#
+ #{e\ 5192}#)))
+ (#{global-extend\ 3793}#
'core
'if
- (lambda (#{e\ 2364}#
- #{r\ 2365}#
- #{w\ 2366}#
- #{s\ 2367}#
- #{mod\ 2368}#)
- ((lambda (#{tmp\ 2369}#)
- ((lambda (#{tmp\ 2370}#)
- (if #{tmp\ 2370}#
- (apply (lambda (#{_\ 2371}# #{test\ 2372}# #{then\ 2373}#)
- (#{build-conditional\ 1265}#
- #{s\ 2367}#
- (#{chi\ 1333}#
- #{test\ 2372}#
- #{r\ 2365}#
- #{w\ 2366}#
- #{mod\ 2368}#)
- (#{chi\ 1333}#
- #{then\ 2373}#
- #{r\ 2365}#
- #{w\ 2366}#
- #{mod\ 2368}#)
- (#{build-void\ 1263}# #f)))
- #{tmp\ 2370}#)
- ((lambda (#{tmp\ 2374}#)
- (if #{tmp\ 2374}#
- (apply (lambda (#{_\ 2375}#
- #{test\ 2376}#
- #{then\ 2377}#
- #{else\ 2378}#)
- (#{build-conditional\ 1265}#
- #{s\ 2367}#
- (#{chi\ 1333}#
- #{test\ 2376}#
- #{r\ 2365}#
- #{w\ 2366}#
- #{mod\ 2368}#)
- (#{chi\ 1333}#
- #{then\ 2377}#
- #{r\ 2365}#
- #{w\ 2366}#
- #{mod\ 2368}#)
- (#{chi\ 1333}#
- #{else\ 2378}#
- #{r\ 2365}#
- #{w\ 2366}#
- #{mod\ 2368}#)))
- #{tmp\ 2374}#)
+ (lambda (#{e\ 5203}#
+ #{r\ 5204}#
+ #{w\ 5205}#
+ #{s\ 5206}#
+ #{mod\ 5207}#)
+ ((lambda (#{tmp\ 5208}#)
+ ((lambda (#{tmp\ 5209}#)
+ (if #{tmp\ 5209}#
+ (apply (lambda (#{_\ 5210}# #{test\ 5211}# #{then\ 5212}#)
+ (#{build-conditional\ 3761}#
+ #{s\ 5206}#
+ (#{chi\ 3831}#
+ #{test\ 5211}#
+ #{r\ 5204}#
+ #{w\ 5205}#
+ #{mod\ 5207}#)
+ (#{chi\ 3831}#
+ #{then\ 5212}#
+ #{r\ 5204}#
+ #{w\ 5205}#
+ #{mod\ 5207}#)
+ (#{build-void\ 3759}# #f)))
+ #{tmp\ 5209}#)
+ ((lambda (#{tmp\ 5213}#)
+ (if #{tmp\ 5213}#
+ (apply (lambda (#{_\ 5214}#
+ #{test\ 5215}#
+ #{then\ 5216}#
+ #{else\ 5217}#)
+ (#{build-conditional\ 3761}#
+ #{s\ 5206}#
+ (#{chi\ 3831}#
+ #{test\ 5215}#
+ #{r\ 5204}#
+ #{w\ 5205}#
+ #{mod\ 5207}#)
+ (#{chi\ 3831}#
+ #{then\ 5216}#
+ #{r\ 5204}#
+ #{w\ 5205}#
+ #{mod\ 5207}#)
+ (#{chi\ 3831}#
+ #{else\ 5217}#
+ #{r\ 5204}#
+ #{w\ 5205}#
+ #{mod\ 5207}#)))
+ #{tmp\ 5213}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2369}#)))
+ #{tmp\ 5208}#)))
($sc-dispatch
- #{tmp\ 2369}#
+ #{tmp\ 5208}#
'(any any any any)))))
($sc-dispatch
- #{tmp\ 2369}#
+ #{tmp\ 5208}#
'(any any any))))
- #{e\ 2364}#)))
- (#{global-extend\ 1295}#
+ #{e\ 5203}#)))
+ (#{global-extend\ 3793}#
'begin
'begin
'())
- (#{global-extend\ 1295}#
+ (#{global-extend\ 3793}#
'define
'define
'())
- (#{global-extend\ 1295}#
+ (#{global-extend\ 3793}#
'define-syntax
'define-syntax
'())
- (#{global-extend\ 1295}#
+ (#{global-extend\ 3793}#
'eval-when
'eval-when
'())
- (#{global-extend\ 1295}#
+ (#{global-extend\ 3793}#
'core
'syntax-case
- (letrec ((#{gen-syntax-case\ 2382}#
- (lambda (#{x\ 2383}#
- #{keys\ 2384}#
- #{clauses\ 2385}#
- #{r\ 2386}#
- #{mod\ 2387}#)
- (if (null? #{clauses\ 2385}#)
- (#{build-application\ 1264}#
+ (letrec ((#{gen-syntax-case\ 5221}#
+ (lambda (#{x\ 5222}#
+ #{keys\ 5223}#
+ #{clauses\ 5224}#
+ #{r\ 5225}#
+ #{mod\ 5226}#)
+ (if (null? #{clauses\ 5224}#)
+ (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 3772}#
#f
'syntax-violation)
- (list (#{build-data\ 1275}# #f #f)
- (#{build-data\ 1275}#
+ (list (#{build-data\ 3773}# #f #f)
+ (#{build-data\ 3773}#
#f
"source expression failed to match any pattern")
- #{x\ 2383}#))
- ((lambda (#{tmp\ 2388}#)
- ((lambda (#{tmp\ 2389}#)
- (if #{tmp\ 2389}#
- (apply (lambda (#{pat\ 2390}# #{exp\ 2391}#)
- (if (if (#{id?\ 1297}# #{pat\ 2390}#)
+ #{x\ 5222}#))
+ ((lambda (#{tmp\ 5227}#)
+ ((lambda (#{tmp\ 5228}#)
+ (if #{tmp\ 5228}#
+ (apply (lambda (#{pat\ 5229}# #{exp\ 5230}#)
+ (if (if (#{id?\ 3795}# #{pat\ 5229}#)
(and-map
- (lambda (#{x\ 2392}#)
- (not (#{free-id=?\ 1320}#
- #{pat\ 2390}#
- #{x\ 2392}#)))
+ (lambda (#{x\ 5231}#)
+ (not (#{free-id=?\ 3818}#
+ #{pat\ 5229}#
+ #{x\ 5231}#)))
(cons '#(syntax-object
...
((top)
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
((top) (top))
("i" "i")))
(hygiene guile))
- #{keys\ 2384}#))
+ #{keys\ 5223}#))
#f)
- (let ((#{labels\ 2393}#
- (list (#{gen-label\ 1302}#)))
- (#{var\ 2394}#
- (#{gen-var\ 1344}#
- #{pat\ 2390}#)))
- (#{build-application\ 1264}#
+ (let ((#{labels\ 5232}#
+ (list (#{gen-label\ 3800}#)))
+ (#{var\ 5233}#
+ (#{gen-var\ 3845}#
+ #{pat\ 5229}#)))
+ (#{build-application\ 3760}#
#f
- (#{build-lambda\ 1273}#
+ (#{build-simple-lambda\ 3769}#
#f
(list (syntax->datum
- #{pat\ 2390}#))
- (list #{var\ 2394}#)
+ #{pat\ 5229}#))
+ #f
+ (list #{var\ 5233}#)
#f
- (#{chi\ 1333}#
- #{exp\ 2391}#
- (#{extend-env\ 1291}#
- #{labels\ 2393}#
+ (#{chi\ 3831}#
+ #{exp\ 5230}#
+ (#{extend-env\ 3789}#
+ #{labels\ 5232}#
(list (cons 'syntax
- (cons #{var\ 2394}#
+ (cons #{var\ 5233}#
0)))
- #{r\ 2386}#)
- (#{make-binding-wrap\ 1314}#
- (list #{pat\ 2390}#)
- #{labels\ 2393}#
+ #{r\ 5225}#)
+ (#{make-binding-wrap\ 3812}#
+ (list #{pat\ 5229}#)
+ #{labels\ 5232}#
'(()))
- #{mod\ 2387}#))
- (list #{x\ 2383}#)))
- (#{gen-clause\ 2381}#
- #{x\ 2383}#
- #{keys\ 2384}#
- (cdr #{clauses\ 2385}#)
- #{r\ 2386}#
- #{pat\ 2390}#
+ #{mod\ 5226}#))
+ (list #{x\ 5222}#)))
+ (#{gen-clause\ 5220}#
+ #{x\ 5222}#
+ #{keys\ 5223}#
+ (cdr #{clauses\ 5224}#)
+ #{r\ 5225}#
+ #{pat\ 5229}#
#t
- #{exp\ 2391}#
- #{mod\ 2387}#)))
- #{tmp\ 2389}#)
- ((lambda (#{tmp\ 2395}#)
- (if #{tmp\ 2395}#
- (apply (lambda (#{pat\ 2396}#
- #{fender\ 2397}#
- #{exp\ 2398}#)
- (#{gen-clause\ 2381}#
- #{x\ 2383}#
- #{keys\ 2384}#
- (cdr #{clauses\ 2385}#)
- #{r\ 2386}#
- #{pat\ 2396}#
- #{fender\ 2397}#
- #{exp\ 2398}#
- #{mod\ 2387}#))
- #{tmp\ 2395}#)
- ((lambda (#{_\ 2399}#)
+ #{exp\ 5230}#
+ #{mod\ 5226}#)))
+ #{tmp\ 5228}#)
+ ((lambda (#{tmp\ 5234}#)
+ (if #{tmp\ 5234}#
+ (apply (lambda (#{pat\ 5235}#
+ #{fender\ 5236}#
+ #{exp\ 5237}#)
+ (#{gen-clause\ 5220}#
+ #{x\ 5222}#
+ #{keys\ 5223}#
+ (cdr #{clauses\ 5224}#)
+ #{r\ 5225}#
+ #{pat\ 5235}#
+ #{fender\ 5236}#
+ #{exp\ 5237}#
+ #{mod\ 5226}#))
+ #{tmp\ 5234}#)
+ ((lambda (#{_\ 5238}#)
(syntax-violation
'syntax-case
"invalid clause"
- (car #{clauses\ 2385}#)))
- #{tmp\ 2388}#)))
+ (car #{clauses\ 5224}#)))
+ #{tmp\ 5227}#)))
($sc-dispatch
- #{tmp\ 2388}#
+ #{tmp\ 5227}#
'(any any any)))))
- ($sc-dispatch #{tmp\ 2388}# (quote (any any)))))
- (car #{clauses\ 2385}#)))))
- (#{gen-clause\ 2381}#
- (lambda (#{x\ 2400}#
- #{keys\ 2401}#
- #{clauses\ 2402}#
- #{r\ 2403}#
- #{pat\ 2404}#
- #{fender\ 2405}#
- #{exp\ 2406}#
- #{mod\ 2407}#)
+ ($sc-dispatch #{tmp\ 5227}# (quote (any any)))))
+ (car #{clauses\ 5224}#)))))
+ (#{gen-clause\ 5220}#
+ (lambda (#{x\ 5239}#
+ #{keys\ 5240}#
+ #{clauses\ 5241}#
+ #{r\ 5242}#
+ #{pat\ 5243}#
+ #{fender\ 5244}#
+ #{exp\ 5245}#
+ #{mod\ 5246}#)
(call-with-values
(lambda ()
- (#{convert-pattern\ 2379}#
- #{pat\ 2404}#
- #{keys\ 2401}#))
- (lambda (#{p\ 2408}# #{pvars\ 2409}#)
- (if (not (#{distinct-bound-ids?\ 1323}#
- (map car #{pvars\ 2409}#)))
+ (#{convert-pattern\ 5218}#
+ #{pat\ 5243}#
+ #{keys\ 5240}#))
+ (lambda (#{p\ 5247}# #{pvars\ 5248}#)
+ (if (not (#{distinct-bound-ids?\ 3821}#
+ (map car #{pvars\ 5248}#)))
(syntax-violation
'syntax-case
"duplicate pattern variable"
- #{pat\ 2404}#)
+ #{pat\ 5243}#)
(if (not (and-map
- (lambda (#{x\ 2410}#)
- (not (#{ellipsis?\ 1342}#
- (car #{x\ 2410}#))))
- #{pvars\ 2409}#))
+ (lambda (#{x\ 5249}#)
+ (not (#{ellipsis?\ 3839}#
+ (car #{x\ 5249}#))))
+ #{pvars\ 5248}#))
(syntax-violation
'syntax-case
"misplaced ellipsis"
- #{pat\ 2404}#)
- (let ((#{y\ 2411}#
- (#{gen-var\ 1344}# (quote tmp))))
- (#{build-application\ 1264}#
+ #{pat\ 5243}#)
+ (let ((#{y\ 5250}#
+ (#{gen-var\ 3845}# (quote tmp))))
+ (#{build-application\ 3760}#
#f
- (#{build-lambda\ 1273}#
+ (#{build-simple-lambda\ 3769}#
#f
(list (quote tmp))
- (list #{y\ 2411}#)
#f
- (let ((#{y\ 2412}#
- (#{build-lexical-reference\ 1266}#
+ (list #{y\ 5250}#)
+ #f
+ (let ((#{y\ 5251}#
+ (#{build-lexical-reference\ 3762}#
'value
#f
'tmp
- #{y\ 2411}#)))
- (#{build-conditional\ 1265}#
+ #{y\ 5250}#)))
+ (#{build-conditional\ 3761}#
#f
- ((lambda (#{tmp\ 2413}#)
- ((lambda (#{tmp\ 2414}#)
- (if #{tmp\ 2414}#
- (apply (lambda () #{y\ 2412}#)
- #{tmp\ 2414}#)
- ((lambda (#{_\ 2415}#)
- (#{build-conditional\ 1265}#
+ ((lambda (#{tmp\ 5252}#)
+ ((lambda (#{tmp\ 5253}#)
+ (if #{tmp\ 5253}#
+ (apply (lambda () #{y\ 5251}#)
+ #{tmp\ 5253}#)
+ ((lambda (#{_\ 5254}#)
+ (#{build-conditional\ 3761}#
#f
- #{y\ 2412}#
- (#{build-dispatch-call\ 2380}#
- #{pvars\ 2409}#
- #{fender\ 2405}#
- #{y\ 2412}#
- #{r\ 2403}#
- #{mod\ 2407}#)
- (#{build-data\ 1275}#
+ #{y\ 5251}#
+ (#{build-dispatch-call\ 5219}#
+ #{pvars\ 5248}#
+ #{fender\ 5244}#
+ #{y\ 5251}#
+ #{r\ 5242}#
+ #{mod\ 5246}#)
+ (#{build-data\ 3773}#
#f
#f)))
- #{tmp\ 2413}#)))
+ #{tmp\ 5252}#)))
($sc-dispatch
- #{tmp\ 2413}#
+ #{tmp\ 5252}#
'#(atom #t))))
- #{fender\ 2405}#)
- (#{build-dispatch-call\ 2380}#
- #{pvars\ 2409}#
- #{exp\ 2406}#
- #{y\ 2412}#
- #{r\ 2403}#
- #{mod\ 2407}#)
- (#{gen-syntax-case\ 2382}#
- #{x\ 2400}#
- #{keys\ 2401}#
- #{clauses\ 2402}#
- #{r\ 2403}#
- #{mod\ 2407}#))))
- (list (if (eq? #{p\ 2408}# (quote any))
- (#{build-application\ 1264}#
+ #{fender\ 5244}#)
+ (#{build-dispatch-call\ 5219}#
+ #{pvars\ 5248}#
+ #{exp\ 5245}#
+ #{y\ 5251}#
+ #{r\ 5242}#
+ #{mod\ 5246}#)
+ (#{gen-syntax-case\ 5221}#
+ #{x\ 5239}#
+ #{keys\ 5240}#
+ #{clauses\ 5241}#
+ #{r\ 5242}#
+ #{mod\ 5246}#))))
+ (list (if (eq? #{p\ 5247}# (quote any))
+ (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 3772}#
#f
'list)
- (list #{x\ 2400}#))
- (#{build-application\ 1264}#
+ (list #{x\ 5239}#))
+ (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 3772}#
#f
'$sc-dispatch)
- (list #{x\ 2400}#
- (#{build-data\ 1275}#
+ (list #{x\ 5239}#
+ (#{build-data\ 3773}#
#f
- #{p\ 2408}#)))))))))))))
- (#{build-dispatch-call\ 2380}#
- (lambda (#{pvars\ 2416}#
- #{exp\ 2417}#
- #{y\ 2418}#
- #{r\ 2419}#
- #{mod\ 2420}#)
- (let ((#{ids\ 2421}# (map car #{pvars\ 2416}#))
- (#{levels\ 2422}# (map cdr #{pvars\ 2416}#)))
- (let ((#{labels\ 2423}#
- (#{gen-labels\ 1303}# #{ids\ 2421}#))
- (#{new-vars\ 2424}#
- (map #{gen-var\ 1344}# #{ids\ 2421}#)))
- (#{build-application\ 1264}#
+ #{p\ 5247}#)))))))))))))
+ (#{build-dispatch-call\ 5219}#
+ (lambda (#{pvars\ 5255}#
+ #{exp\ 5256}#
+ #{y\ 5257}#
+ #{r\ 5258}#
+ #{mod\ 5259}#)
+ (let ((#{ids\ 5260}# (map car #{pvars\ 5255}#))
+ (#{levels\ 5261}# (map cdr #{pvars\ 5255}#)))
+ (let ((#{labels\ 5262}#
+ (#{gen-labels\ 3801}# #{ids\ 5260}#))
+ (#{new-vars\ 5263}#
+ (map #{gen-var\ 3845}# #{ids\ 5260}#)))
+ (#{build-application\ 3760}#
#f
- (#{build-primref\ 1274}# #f (quote apply))
- (list (#{build-lambda\ 1273}#
+ (#{build-primref\ 3772}# #f (quote apply))
+ (list (#{build-simple-lambda\ 3769}#
+ #f
+ (map syntax->datum #{ids\ 5260}#)
#f
- (map syntax->datum #{ids\ 2421}#)
- #{new-vars\ 2424}#
+ #{new-vars\ 5263}#
#f
- (#{chi\ 1333}#
- #{exp\ 2417}#
- (#{extend-env\ 1291}#
- #{labels\ 2423}#
- (map (lambda (#{var\ 2425}#
- #{level\ 2426}#)
+ (#{chi\ 3831}#
+ #{exp\ 5256}#
+ (#{extend-env\ 3789}#
+ #{labels\ 5262}#
+ (map (lambda (#{var\ 5264}#
+ #{level\ 5265}#)
(cons 'syntax
- (cons #{var\ 2425}#
- #{level\ 2426}#)))
- #{new-vars\ 2424}#
- (map cdr #{pvars\ 2416}#))
- #{r\ 2419}#)
- (#{make-binding-wrap\ 1314}#
- #{ids\ 2421}#
- #{labels\ 2423}#
+ (cons #{var\ 5264}#
+ #{level\ 5265}#)))
+ #{new-vars\ 5263}#
+ (map cdr #{pvars\ 5255}#))
+ #{r\ 5258}#)
+ (#{make-binding-wrap\ 3812}#
+ #{ids\ 5260}#
+ #{labels\ 5262}#
'(()))
- #{mod\ 2420}#))
- #{y\ 2418}#))))))
- (#{convert-pattern\ 2379}#
- (lambda (#{pattern\ 2427}# #{keys\ 2428}#)
- (letrec ((#{cvt\ 2429}#
- (lambda (#{p\ 2430}# #{n\ 2431}# #{ids\ 2432}#)
- (if (#{id?\ 1297}# #{p\ 2430}#)
- (if (#{bound-id-member?\ 1324}#
- #{p\ 2430}#
- #{keys\ 2428}#)
+ #{mod\ 5259}#))
+ #{y\ 5257}#))))))
+ (#{convert-pattern\ 5218}#
+ (lambda (#{pattern\ 5266}# #{keys\ 5267}#)
+ (letrec ((#{cvt\ 5268}#
+ (lambda (#{p\ 5269}# #{n\ 5270}# #{ids\ 5271}#)
+ (if (#{id?\ 3795}# #{p\ 5269}#)
+ (if (#{bound-id-member?\ 3822}#
+ #{p\ 5269}#
+ #{keys\ 5267}#)
(values
- (vector (quote free-id) #{p\ 2430}#)
- #{ids\ 2432}#)
+ (vector (quote free-id) #{p\ 5269}#)
+ #{ids\ 5271}#)
(values
'any
- (cons (cons #{p\ 2430}# #{n\ 2431}#)
- #{ids\ 2432}#)))
- ((lambda (#{tmp\ 2433}#)
- ((lambda (#{tmp\ 2434}#)
- (if (if #{tmp\ 2434}#
- (apply (lambda (#{x\ 2435}#
- #{dots\ 2436}#)
- (#{ellipsis?\ 1342}#
- #{dots\ 2436}#))
- #{tmp\ 2434}#)
+ (cons (cons #{p\ 5269}# #{n\ 5270}#)
+ #{ids\ 5271}#)))
+ ((lambda (#{tmp\ 5272}#)
+ ((lambda (#{tmp\ 5273}#)
+ (if (if #{tmp\ 5273}#
+ (apply (lambda (#{x\ 5274}#
+ #{dots\ 5275}#)
+ (#{ellipsis?\ 3839}#
+ #{dots\ 5275}#))
+ #{tmp\ 5273}#)
#f)
- (apply (lambda (#{x\ 2437}#
- #{dots\ 2438}#)
+ (apply (lambda (#{x\ 5276}#
+ #{dots\ 5277}#)
(call-with-values
(lambda ()
- (#{cvt\ 2429}#
- #{x\ 2437}#
- (#{fx+\ 1254}#
- #{n\ 2431}#
+ (#{cvt\ 5268}#
+ #{x\ 5276}#
+ (#{fx+\ 3750}#
+ #{n\ 5270}#
1)
- #{ids\ 2432}#))
- (lambda (#{p\ 2439}#
- #{ids\ 2440}#)
+ #{ids\ 5271}#))
+ (lambda (#{p\ 5278}#
+ #{ids\ 5279}#)
(values
- (if (eq? #{p\ 2439}#
+ (if (eq? #{p\ 5278}#
'any)
'each-any
(vector
'each
- #{p\ 2439}#))
- #{ids\ 2440}#))))
- #{tmp\ 2434}#)
- ((lambda (#{tmp\ 2441}#)
- (if #{tmp\ 2441}#
- (apply (lambda (#{x\ 2442}#
- #{y\ 2443}#)
+ #{p\ 5278}#))
+ #{ids\ 5279}#))))
+ #{tmp\ 5273}#)
+ ((lambda (#{tmp\ 5280}#)
+ (if #{tmp\ 5280}#
+ (apply (lambda (#{x\ 5281}#
+ #{y\ 5282}#)
(call-with-values
(lambda ()
- (#{cvt\ 2429}#
- #{y\ 2443}#
- #{n\ 2431}#
- #{ids\ 2432}#))
- (lambda (#{y\ 2444}#
- #{ids\ 2445}#)
+ (#{cvt\ 5268}#
+ #{y\ 5282}#
+ #{n\ 5270}#
+ #{ids\ 5271}#))
+ (lambda (#{y\ 5283}#
+ #{ids\ 5284}#)
(call-with-values
(lambda ()
- (#{cvt\ 2429}#
- #{x\ 2442}#
- #{n\ 2431}#
- #{ids\ 2445}#))
- (lambda (#{x\ 2446}#
- #{ids\ 2447}#)
+ (#{cvt\ 5268}#
+ #{x\ 5281}#
+ #{n\ 5270}#
+ #{ids\ 5284}#))
+ (lambda (#{x\ 5285}#
+ #{ids\ 5286}#)
(values
- (cons #{x\ 2446}#
- #{y\ 2444}#)
- #{ids\ 2447}#))))))
- #{tmp\ 2441}#)
- ((lambda (#{tmp\ 2448}#)
- (if #{tmp\ 2448}#
+ (cons #{x\ 5285}#
+ #{y\ 5283}#)
+ #{ids\ 5286}#))))))
+ #{tmp\ 5280}#)
+ ((lambda (#{tmp\ 5287}#)
+ (if #{tmp\ 5287}#
(apply (lambda ()
(values
'()
- #{ids\ 2432}#))
- #{tmp\ 2448}#)
- ((lambda (#{tmp\ 2449}#)
- (if #{tmp\ 2449}#
- (apply (lambda (#{x\ 2450}#)
+ #{ids\ 5271}#))
+ #{tmp\ 5287}#)
+ ((lambda (#{tmp\ 5288}#)
+ (if #{tmp\ 5288}#
+ (apply (lambda (#{x\ 5289}#)
(call-with-values
(lambda ()
- (#{cvt\ 2429}#
- #{x\ 2450}#
- #{n\ 2431}#
- #{ids\ 2432}#))
- (lambda (#{p\ 2452}#
- #{ids\ 2453}#)
+ (#{cvt\ 5268}#
+ #{x\ 5289}#
+ #{n\ 5270}#
+ #{ids\ 5271}#))
+ (lambda (#{p\ 5291}#
+ #{ids\ 5292}#)
(values
(vector
'vector
- #{p\ 2452}#)
- #{ids\ 2453}#))))
- #{tmp\ 2449}#)
- ((lambda (#{x\ 2454}#)
+ #{p\ 5291}#)
+ #{ids\ 5292}#))))
+ #{tmp\ 5288}#)
+ ((lambda (#{x\ 5293}#)
(values
(vector
'atom
- (#{strip\ 1343}#
- #{p\ 2430}#
+ (#{strip\ 3844}#
+ #{p\ 5269}#
'(())))
- #{ids\ 2432}#))
- #{tmp\ 2433}#)))
+ #{ids\ 5271}#))
+ #{tmp\ 5272}#)))
($sc-dispatch
- #{tmp\ 2433}#
+ #{tmp\ 5272}#
'#(vector
each-any)))))
($sc-dispatch
- #{tmp\ 2433}#
+ #{tmp\ 5272}#
'()))))
($sc-dispatch
- #{tmp\ 2433}#
+ #{tmp\ 5272}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 2433}#
+ #{tmp\ 5272}#
'(any any))))
- #{p\ 2430}#)))))
- (#{cvt\ 2429}# #{pattern\ 2427}# 0 (quote ()))))))
- (lambda (#{e\ 2455}#
- #{r\ 2456}#
- #{w\ 2457}#
- #{s\ 2458}#
- #{mod\ 2459}#)
- (let ((#{e\ 2460}#
- (#{source-wrap\ 1326}#
- #{e\ 2455}#
- #{w\ 2457}#
- #{s\ 2458}#
- #{mod\ 2459}#)))
- ((lambda (#{tmp\ 2461}#)
- ((lambda (#{tmp\ 2462}#)
- (if #{tmp\ 2462}#
- (apply (lambda (#{_\ 2463}#
- #{val\ 2464}#
- #{key\ 2465}#
- #{m\ 2466}#)
+ #{p\ 5269}#)))))
+ (#{cvt\ 5268}# #{pattern\ 5266}# 0 (quote ()))))))
+ (lambda (#{e\ 5294}#
+ #{r\ 5295}#
+ #{w\ 5296}#
+ #{s\ 5297}#
+ #{mod\ 5298}#)
+ (let ((#{e\ 5299}#
+ (#{source-wrap\ 3824}#
+ #{e\ 5294}#
+ #{w\ 5296}#
+ #{s\ 5297}#
+ #{mod\ 5298}#)))
+ ((lambda (#{tmp\ 5300}#)
+ ((lambda (#{tmp\ 5301}#)
+ (if #{tmp\ 5301}#
+ (apply (lambda (#{_\ 5302}#
+ #{val\ 5303}#
+ #{key\ 5304}#
+ #{m\ 5305}#)
(if (and-map
- (lambda (#{x\ 2467}#)
- (if (#{id?\ 1297}# #{x\ 2467}#)
- (not (#{ellipsis?\ 1342}#
- #{x\ 2467}#))
+ (lambda (#{x\ 5306}#)
+ (if (#{id?\ 3795}# #{x\ 5306}#)
+ (not (#{ellipsis?\ 3839}#
+ #{x\ 5306}#))
#f))
- #{key\ 2465}#)
- (let ((#{x\ 2469}#
- (#{gen-var\ 1344}# (quote tmp))))
- (#{build-application\ 1264}#
- #{s\ 2458}#
- (#{build-lambda\ 1273}#
+ #{key\ 5304}#)
+ (let ((#{x\ 5308}#
+ (#{gen-var\ 3845}# (quote tmp))))
+ (#{build-application\ 3760}#
+ #{s\ 5297}#
+ (#{build-simple-lambda\ 3769}#
#f
(list (quote tmp))
- (list #{x\ 2469}#)
#f
- (#{gen-syntax-case\ 2382}#
- (#{build-lexical-reference\ 1266}#
+ (list #{x\ 5308}#)
+ #f
+ (#{gen-syntax-case\ 5221}#
+ (#{build-lexical-reference\ 3762}#
'value
#f
'tmp
- #{x\ 2469}#)
- #{key\ 2465}#
- #{m\ 2466}#
- #{r\ 2456}#
- #{mod\ 2459}#))
- (list (#{chi\ 1333}#
- #{val\ 2464}#
- #{r\ 2456}#
+ #{x\ 5308}#)
+ #{key\ 5304}#
+ #{m\ 5305}#
+ #{r\ 5295}#
+ #{mod\ 5298}#))
+ (list (#{chi\ 3831}#
+ #{val\ 5303}#
+ #{r\ 5295}#
'(())
- #{mod\ 2459}#))))
+ #{mod\ 5298}#))))
(syntax-violation
'syntax-case
"invalid literals list"
- #{e\ 2460}#)))
- #{tmp\ 2462}#)
+ #{e\ 5299}#)))
+ #{tmp\ 5301}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2461}#)))
+ #{tmp\ 5300}#)))
($sc-dispatch
- #{tmp\ 2461}#
+ #{tmp\ 5300}#
'(any any each-any . each-any))))
- #{e\ 2460}#)))))
+ #{e\ 5299}#)))))
(set! sc-expand
- (lambda (#{x\ 2473}# . #{rest\ 2472}#)
- (if (if (pair? #{x\ 2473}#)
- (equal? (car #{x\ 2473}#) #{noexpand\ 1252}#)
+ (lambda (#{x\ 5311}# . #{rest\ 5312}#)
+ (if (if (pair? #{x\ 5311}#)
+ (equal? (car #{x\ 5311}#) #{noexpand\ 3748}#)
#f)
- (cadr #{x\ 2473}#)
- (let ((#{m\ 2474}#
- (if (null? #{rest\ 2472}#)
+ (cadr #{x\ 5311}#)
+ (let ((#{m\ 5313}#
+ (if (null? #{rest\ 5312}#)
'e
- (car #{rest\ 2472}#)))
- (#{esew\ 2475}#
- (if (let ((#{t\ 2476}# (null? #{rest\ 2472}#)))
- (if #{t\ 2476}#
- #{t\ 2476}#
- (null? (cdr #{rest\ 2472}#))))
+ (car #{rest\ 5312}#)))
+ (#{esew\ 5314}#
+ (if (let ((#{t\ 5315}# (null? #{rest\ 5312}#)))
+ (if #{t\ 5315}#
+ #{t\ 5315}#
+ (null? (cdr #{rest\ 5312}#))))
'(eval)
- (cadr #{rest\ 2472}#))))
+ (cadr #{rest\ 5312}#))))
(with-fluid*
- #{*mode*\ 1253}#
- #{m\ 2474}#
+ #{*mode*\ 3749}#
+ #{m\ 5313}#
(lambda ()
- (#{chi-top\ 1332}#
- #{x\ 2473}#
+ (#{chi-top\ 3830}#
+ #{x\ 5311}#
'()
'((top))
- #{m\ 2474}#
- #{esew\ 2475}#
+ #{m\ 5313}#
+ #{esew\ 5314}#
(cons 'hygiene
(module-name (current-module))))))))))
(set! identifier?
- (lambda (#{x\ 2477}#)
- (#{nonsymbol-id?\ 1296}# #{x\ 2477}#)))
+ (lambda (#{x\ 5316}#)
+ (#{nonsymbol-id?\ 3794}# #{x\ 5316}#)))
(set! datum->syntax
- (lambda (#{id\ 2478}# #{datum\ 2479}#)
- (#{make-syntax-object\ 1280}#
- #{datum\ 2479}#
- (#{syntax-object-wrap\ 1283}# #{id\ 2478}#)
+ (lambda (#{id\ 5317}# #{datum\ 5318}#)
+ (#{make-syntax-object\ 3778}#
+ #{datum\ 5318}#
+ (#{syntax-object-wrap\ 3781}# #{id\ 5317}#)
#f)))
(set! syntax->datum
- (lambda (#{x\ 2480}#)
- (#{strip\ 1343}# #{x\ 2480}# (quote (())))))
+ (lambda (#{x\ 5319}#)
+ (#{strip\ 3844}# #{x\ 5319}# (quote (())))))
(set! generate-temporaries
- (lambda (#{ls\ 2481}#)
+ (lambda (#{ls\ 5320}#)
(begin
- (let ((#{x\ 2482}# #{ls\ 2481}#))
- (if (not (list? #{x\ 2482}#))
+ (let ((#{x\ 5321}# #{ls\ 5320}#))
+ (if (not (list? #{x\ 5321}#))
(syntax-violation
'generate-temporaries
"invalid argument"
- #{x\ 2482}#)))
- (map (lambda (#{x\ 2483}#)
- (#{wrap\ 1325}# (gensym) (quote ((top))) #f))
- #{ls\ 2481}#))))
+ #{x\ 5321}#)))
+ (map (lambda (#{x\ 5322}#)
+ (#{wrap\ 3823}# (gensym) (quote ((top))) #f))
+ #{ls\ 5320}#))))
(set! free-identifier=?
- (lambda (#{x\ 2484}# #{y\ 2485}#)
+ (lambda (#{x\ 5323}# #{y\ 5324}#)
(begin
- (let ((#{x\ 2486}# #{x\ 2484}#))
- (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2486}#))
+ (let ((#{x\ 5325}# #{x\ 5323}#))
+ (if (not (#{nonsymbol-id?\ 3794}# #{x\ 5325}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- #{x\ 2486}#)))
- (let ((#{x\ 2487}# #{y\ 2485}#))
- (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2487}#))
+ #{x\ 5325}#)))
+ (let ((#{x\ 5326}# #{y\ 5324}#))
+ (if (not (#{nonsymbol-id?\ 3794}# #{x\ 5326}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- #{x\ 2487}#)))
- (#{free-id=?\ 1320}# #{x\ 2484}# #{y\ 2485}#))))
+ #{x\ 5326}#)))
+ (#{free-id=?\ 3818}# #{x\ 5323}# #{y\ 5324}#))))
(set! bound-identifier=?
- (lambda (#{x\ 2488}# #{y\ 2489}#)
+ (lambda (#{x\ 5327}# #{y\ 5328}#)
(begin
- (let ((#{x\ 2490}# #{x\ 2488}#))
- (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2490}#))
+ (let ((#{x\ 5329}# #{x\ 5327}#))
+ (if (not (#{nonsymbol-id?\ 3794}# #{x\ 5329}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- #{x\ 2490}#)))
- (let ((#{x\ 2491}# #{y\ 2489}#))
- (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2491}#))
+ #{x\ 5329}#)))
+ (let ((#{x\ 5330}# #{y\ 5328}#))
+ (if (not (#{nonsymbol-id?\ 3794}# #{x\ 5330}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- #{x\ 2491}#)))
- (#{bound-id=?\ 1321}# #{x\ 2488}# #{y\ 2489}#))))
+ #{x\ 5330}#)))
+ (#{bound-id=?\ 3819}# #{x\ 5327}# #{y\ 5328}#))))
(set! syntax-violation
- (lambda (#{who\ 2495}#
- #{message\ 2494}#
- #{form\ 2493}#
+ (lambda (#{who\ 5331}#
+ #{message\ 5332}#
+ #{form\ 5333}#
.
- #{subform\ 2492}#)
+ #{subform\ 5334}#)
(begin
- (let ((#{x\ 2496}# #{who\ 2495}#))
- (if (not ((lambda (#{x\ 2497}#)
- (let ((#{t\ 2498}# (not #{x\ 2497}#)))
- (if #{t\ 2498}#
- #{t\ 2498}#
- (let ((#{t\ 2499}# (string? #{x\ 2497}#)))
- (if #{t\ 2499}#
- #{t\ 2499}#
- (symbol? #{x\ 2497}#))))))
- #{x\ 2496}#))
+ (let ((#{x\ 5335}# #{who\ 5331}#))
+ (if (not ((lambda (#{x\ 5336}#)
+ (let ((#{t\ 5337}# (not #{x\ 5336}#)))
+ (if #{t\ 5337}#
+ #{t\ 5337}#
+ (let ((#{t\ 5338}# (string? #{x\ 5336}#)))
+ (if #{t\ 5338}#
+ #{t\ 5338}#
+ (symbol? #{x\ 5336}#))))))
+ #{x\ 5335}#))
(syntax-violation
'syntax-violation
"invalid argument"
- #{x\ 2496}#)))
- (let ((#{x\ 2500}# #{message\ 2494}#))
- (if (not (string? #{x\ 2500}#))
+ #{x\ 5335}#)))
+ (let ((#{x\ 5339}# #{message\ 5332}#))
+ (if (not (string? #{x\ 5339}#))
(syntax-violation
'syntax-violation
"invalid argument"
- #{x\ 2500}#)))
+ #{x\ 5339}#)))
(scm-error
'syntax-error
'sc-expand
(string-append
- (if #{who\ 2495}# "~a: " "")
+ (if #{who\ 5331}# "~a: " "")
"~a "
- (if (null? #{subform\ 2492}#)
+ (if (null? #{subform\ 5334}#)
"in ~a"
"in subform `~s' of `~s'"))
- (let ((#{tail\ 2501}#
- (cons #{message\ 2494}#
- (map (lambda (#{x\ 2502}#)
- (#{strip\ 1343}# #{x\ 2502}# (quote (()))))
+ (let ((#{tail\ 5340}#
+ (cons #{message\ 5332}#
+ (map (lambda (#{x\ 5341}#)
+ (#{strip\ 3844}# #{x\ 5341}# (quote (()))))
(append
- #{subform\ 2492}#
- (list #{form\ 2493}#))))))
- (if #{who\ 2495}#
- (cons #{who\ 2495}# #{tail\ 2501}#)
- #{tail\ 2501}#))
+ #{subform\ 5334}#
+ (list #{form\ 5333}#))))))
+ (if #{who\ 5331}#
+ (cons #{who\ 5331}# #{tail\ 5340}#)
+ #{tail\ 5340}#))
#f))))
- (letrec ((#{match\ 2507}#
- (lambda (#{e\ 2508}#
- #{p\ 2509}#
- #{w\ 2510}#
- #{r\ 2511}#
- #{mod\ 2512}#)
- (if (not #{r\ 2511}#)
+ (letrec ((#{match\ 5346}#
+ (lambda (#{e\ 5347}#
+ #{p\ 5348}#
+ #{w\ 5349}#
+ #{r\ 5350}#
+ #{mod\ 5351}#)
+ (if (not #{r\ 5350}#)
#f
- (if (eq? #{p\ 2509}# (quote any))
- (cons (#{wrap\ 1325}#
- #{e\ 2508}#
- #{w\ 2510}#
- #{mod\ 2512}#)
- #{r\ 2511}#)
- (if (#{syntax-object?\ 1281}# #{e\ 2508}#)
- (#{match*\ 2506}#
- (#{syntax-object-expression\ 1282}# #{e\ 2508}#)
- #{p\ 2509}#
- (#{join-wraps\ 1316}#
- #{w\ 2510}#
- (#{syntax-object-wrap\ 1283}# #{e\ 2508}#))
- #{r\ 2511}#
- (#{syntax-object-module\ 1284}# #{e\ 2508}#))
- (#{match*\ 2506}#
- #{e\ 2508}#
- #{p\ 2509}#
- #{w\ 2510}#
- #{r\ 2511}#
- #{mod\ 2512}#))))))
- (#{match*\ 2506}#
- (lambda (#{e\ 2513}#
- #{p\ 2514}#
- #{w\ 2515}#
- #{r\ 2516}#
- #{mod\ 2517}#)
- (if (null? #{p\ 2514}#)
- (if (null? #{e\ 2513}#) #{r\ 2516}# #f)
- (if (pair? #{p\ 2514}#)
- (if (pair? #{e\ 2513}#)
- (#{match\ 2507}#
- (car #{e\ 2513}#)
- (car #{p\ 2514}#)
- #{w\ 2515}#
- (#{match\ 2507}#
- (cdr #{e\ 2513}#)
- (cdr #{p\ 2514}#)
- #{w\ 2515}#
- #{r\ 2516}#
- #{mod\ 2517}#)
- #{mod\ 2517}#)
+ (if (eq? #{p\ 5348}# (quote any))
+ (cons (#{wrap\ 3823}#
+ #{e\ 5347}#
+ #{w\ 5349}#
+ #{mod\ 5351}#)
+ #{r\ 5350}#)
+ (if (#{syntax-object?\ 3779}# #{e\ 5347}#)
+ (#{match*\ 5345}#
+ (#{syntax-object-expression\ 3780}# #{e\ 5347}#)
+ #{p\ 5348}#
+ (#{join-wraps\ 3814}#
+ #{w\ 5349}#
+ (#{syntax-object-wrap\ 3781}# #{e\ 5347}#))
+ #{r\ 5350}#
+ (#{syntax-object-module\ 3782}# #{e\ 5347}#))
+ (#{match*\ 5345}#
+ #{e\ 5347}#
+ #{p\ 5348}#
+ #{w\ 5349}#
+ #{r\ 5350}#
+ #{mod\ 5351}#))))))
+ (#{match*\ 5345}#
+ (lambda (#{e\ 5352}#
+ #{p\ 5353}#
+ #{w\ 5354}#
+ #{r\ 5355}#
+ #{mod\ 5356}#)
+ (if (null? #{p\ 5353}#)
+ (if (null? #{e\ 5352}#) #{r\ 5355}# #f)
+ (if (pair? #{p\ 5353}#)
+ (if (pair? #{e\ 5352}#)
+ (#{match\ 5346}#
+ (car #{e\ 5352}#)
+ (car #{p\ 5353}#)
+ #{w\ 5354}#
+ (#{match\ 5346}#
+ (cdr #{e\ 5352}#)
+ (cdr #{p\ 5353}#)
+ #{w\ 5354}#
+ #{r\ 5355}#
+ #{mod\ 5356}#)
+ #{mod\ 5356}#)
#f)
- (if (eq? #{p\ 2514}# (quote each-any))
- (let ((#{l\ 2518}#
- (#{match-each-any\ 2504}#
- #{e\ 2513}#
- #{w\ 2515}#
- #{mod\ 2517}#)))
- (if #{l\ 2518}#
- (cons #{l\ 2518}# #{r\ 2516}#)
+ (if (eq? #{p\ 5353}# (quote each-any))
+ (let ((#{l\ 5357}#
+ (#{match-each-any\ 5343}#
+ #{e\ 5352}#
+ #{w\ 5354}#
+ #{mod\ 5356}#)))
+ (if #{l\ 5357}#
+ (cons #{l\ 5357}# #{r\ 5355}#)
#f))
- (let ((#{atom-key\ 2519}# (vector-ref #{p\ 2514}# 0)))
- (if (memv #{atom-key\ 2519}# (quote (each)))
- (if (null? #{e\ 2513}#)
- (#{match-empty\ 2505}#
- (vector-ref #{p\ 2514}# 1)
- #{r\ 2516}#)
- (let ((#{l\ 2520}#
- (#{match-each\ 2503}#
- #{e\ 2513}#
- (vector-ref #{p\ 2514}# 1)
- #{w\ 2515}#
- #{mod\ 2517}#)))
- (if #{l\ 2520}#
- (letrec ((#{collect\ 2521}#
- (lambda (#{l\ 2522}#)
- (if (null? (car #{l\ 2522}#))
- #{r\ 2516}#
- (cons (map car #{l\ 2522}#)
- (#{collect\ 2521}#
+ (let ((#{atom-key\ 5358}# (vector-ref #{p\ 5353}# 0)))
+ (if (memv #{atom-key\ 5358}# (quote (each)))
+ (if (null? #{e\ 5352}#)
+ (#{match-empty\ 5344}#
+ (vector-ref #{p\ 5353}# 1)
+ #{r\ 5355}#)
+ (let ((#{l\ 5359}#
+ (#{match-each\ 5342}#
+ #{e\ 5352}#
+ (vector-ref #{p\ 5353}# 1)
+ #{w\ 5354}#
+ #{mod\ 5356}#)))
+ (if #{l\ 5359}#
+ (letrec ((#{collect\ 5360}#
+ (lambda (#{l\ 5361}#)
+ (if (null? (car #{l\ 5361}#))
+ #{r\ 5355}#
+ (cons (map car #{l\ 5361}#)
+ (#{collect\ 5360}#
(map cdr
- #{l\ 2522}#)))))))
- (#{collect\ 2521}# #{l\ 2520}#))
+ #{l\ 5361}#)))))))
+ (#{collect\ 5360}# #{l\ 5359}#))
#f)))
- (if (memv #{atom-key\ 2519}# (quote (free-id)))
- (if (#{id?\ 1297}# #{e\ 2513}#)
- (if (#{free-id=?\ 1320}#
- (#{wrap\ 1325}#
- #{e\ 2513}#
- #{w\ 2515}#
- #{mod\ 2517}#)
- (vector-ref #{p\ 2514}# 1))
- #{r\ 2516}#
+ (if (memv #{atom-key\ 5358}# (quote (free-id)))
+ (if (#{id?\ 3795}# #{e\ 5352}#)
+ (if (#{free-id=?\ 3818}#
+ (#{wrap\ 3823}#
+ #{e\ 5352}#
+ #{w\ 5354}#
+ #{mod\ 5356}#)
+ (vector-ref #{p\ 5353}# 1))
+ #{r\ 5355}#
#f)
#f)
- (if (memv #{atom-key\ 2519}# (quote (atom)))
+ (if (memv #{atom-key\ 5358}# (quote (atom)))
(if (equal?
- (vector-ref #{p\ 2514}# 1)
- (#{strip\ 1343}#
- #{e\ 2513}#
- #{w\ 2515}#))
- #{r\ 2516}#
+ (vector-ref #{p\ 5353}# 1)
+ (#{strip\ 3844}#
+ #{e\ 5352}#
+ #{w\ 5354}#))
+ #{r\ 5355}#
#f)
- (if (memv #{atom-key\ 2519}# (quote (vector)))
- (if (vector? #{e\ 2513}#)
- (#{match\ 2507}#
- (vector->list #{e\ 2513}#)
- (vector-ref #{p\ 2514}# 1)
- #{w\ 2515}#
- #{r\ 2516}#
- #{mod\ 2517}#)
+ (if (memv #{atom-key\ 5358}# (quote (vector)))
+ (if (vector? #{e\ 5352}#)
+ (#{match\ 5346}#
+ (vector->list #{e\ 5352}#)
+ (vector-ref #{p\ 5353}# 1)
+ #{w\ 5354}#
+ #{r\ 5355}#
+ #{mod\ 5356}#)
#f)))))))))))
- (#{match-empty\ 2505}#
- (lambda (#{p\ 2523}# #{r\ 2524}#)
- (if (null? #{p\ 2523}#)
- #{r\ 2524}#
- (if (eq? #{p\ 2523}# (quote any))
- (cons (quote ()) #{r\ 2524}#)
- (if (pair? #{p\ 2523}#)
- (#{match-empty\ 2505}#
- (car #{p\ 2523}#)
- (#{match-empty\ 2505}#
- (cdr #{p\ 2523}#)
- #{r\ 2524}#))
- (if (eq? #{p\ 2523}# (quote each-any))
- (cons (quote ()) #{r\ 2524}#)
- (let ((#{atom-key\ 2525}#
- (vector-ref #{p\ 2523}# 0)))
- (if (memv #{atom-key\ 2525}# (quote (each)))
- (#{match-empty\ 2505}#
- (vector-ref #{p\ 2523}# 1)
- #{r\ 2524}#)
- (if (memv #{atom-key\ 2525}#
+ (#{match-empty\ 5344}#
+ (lambda (#{p\ 5362}# #{r\ 5363}#)
+ (if (null? #{p\ 5362}#)
+ #{r\ 5363}#
+ (if (eq? #{p\ 5362}# (quote any))
+ (cons (quote ()) #{r\ 5363}#)
+ (if (pair? #{p\ 5362}#)
+ (#{match-empty\ 5344}#
+ (car #{p\ 5362}#)
+ (#{match-empty\ 5344}#
+ (cdr #{p\ 5362}#)
+ #{r\ 5363}#))
+ (if (eq? #{p\ 5362}# (quote each-any))
+ (cons (quote ()) #{r\ 5363}#)
+ (let ((#{atom-key\ 5364}#
+ (vector-ref #{p\ 5362}# 0)))
+ (if (memv #{atom-key\ 5364}# (quote (each)))
+ (#{match-empty\ 5344}#
+ (vector-ref #{p\ 5362}# 1)
+ #{r\ 5363}#)
+ (if (memv #{atom-key\ 5364}#
'(free-id atom))
- #{r\ 2524}#
- (if (memv #{atom-key\ 2525}# (quote (vector)))
- (#{match-empty\ 2505}#
- (vector-ref #{p\ 2523}# 1)
- #{r\ 2524}#)))))))))))
- (#{match-each-any\ 2504}#
- (lambda (#{e\ 2526}# #{w\ 2527}# #{mod\ 2528}#)
- (if (pair? #{e\ 2526}#)
- (let ((#{l\ 2529}#
- (#{match-each-any\ 2504}#
- (cdr #{e\ 2526}#)
- #{w\ 2527}#
- #{mod\ 2528}#)))
- (if #{l\ 2529}#
- (cons (#{wrap\ 1325}#
- (car #{e\ 2526}#)
- #{w\ 2527}#
- #{mod\ 2528}#)
- #{l\ 2529}#)
+ #{r\ 5363}#
+ (if (memv #{atom-key\ 5364}# (quote (vector)))
+ (#{match-empty\ 5344}#
+ (vector-ref #{p\ 5362}# 1)
+ #{r\ 5363}#)))))))))))
+ (#{match-each-any\ 5343}#
+ (lambda (#{e\ 5365}# #{w\ 5366}# #{mod\ 5367}#)
+ (if (pair? #{e\ 5365}#)
+ (let ((#{l\ 5368}#
+ (#{match-each-any\ 5343}#
+ (cdr #{e\ 5365}#)
+ #{w\ 5366}#
+ #{mod\ 5367}#)))
+ (if #{l\ 5368}#
+ (cons (#{wrap\ 3823}#
+ (car #{e\ 5365}#)
+ #{w\ 5366}#
+ #{mod\ 5367}#)
+ #{l\ 5368}#)
#f))
- (if (null? #{e\ 2526}#)
+ (if (null? #{e\ 5365}#)
'()
- (if (#{syntax-object?\ 1281}# #{e\ 2526}#)
- (#{match-each-any\ 2504}#
- (#{syntax-object-expression\ 1282}# #{e\ 2526}#)
- (#{join-wraps\ 1316}#
- #{w\ 2527}#
- (#{syntax-object-wrap\ 1283}# #{e\ 2526}#))
- #{mod\ 2528}#)
+ (if (#{syntax-object?\ 3779}# #{e\ 5365}#)
+ (#{match-each-any\ 5343}#
+ (#{syntax-object-expression\ 3780}# #{e\ 5365}#)
+ (#{join-wraps\ 3814}#
+ #{w\ 5366}#
+ (#{syntax-object-wrap\ 3781}# #{e\ 5365}#))
+ #{mod\ 5367}#)
#f)))))
- (#{match-each\ 2503}#
- (lambda (#{e\ 2530}#
- #{p\ 2531}#
- #{w\ 2532}#
- #{mod\ 2533}#)
- (if (pair? #{e\ 2530}#)
- (let ((#{first\ 2534}#
- (#{match\ 2507}#
- (car #{e\ 2530}#)
- #{p\ 2531}#
- #{w\ 2532}#
+ (#{match-each\ 5342}#
+ (lambda (#{e\ 5369}#
+ #{p\ 5370}#
+ #{w\ 5371}#
+ #{mod\ 5372}#)
+ (if (pair? #{e\ 5369}#)
+ (let ((#{first\ 5373}#
+ (#{match\ 5346}#
+ (car #{e\ 5369}#)
+ #{p\ 5370}#
+ #{w\ 5371}#
'()
- #{mod\ 2533}#)))
- (if #{first\ 2534}#
- (let ((#{rest\ 2535}#
- (#{match-each\ 2503}#
- (cdr #{e\ 2530}#)
- #{p\ 2531}#
- #{w\ 2532}#
- #{mod\ 2533}#)))
- (if #{rest\ 2535}#
- (cons #{first\ 2534}# #{rest\ 2535}#)
+ #{mod\ 5372}#)))
+ (if #{first\ 5373}#
+ (let ((#{rest\ 5374}#
+ (#{match-each\ 5342}#
+ (cdr #{e\ 5369}#)
+ #{p\ 5370}#
+ #{w\ 5371}#
+ #{mod\ 5372}#)))
+ (if #{rest\ 5374}#
+ (cons #{first\ 5373}# #{rest\ 5374}#)
#f))
#f))
- (if (null? #{e\ 2530}#)
+ (if (null? #{e\ 5369}#)
'()
- (if (#{syntax-object?\ 1281}# #{e\ 2530}#)
- (#{match-each\ 2503}#
- (#{syntax-object-expression\ 1282}# #{e\ 2530}#)
- #{p\ 2531}#
- (#{join-wraps\ 1316}#
- #{w\ 2532}#
- (#{syntax-object-wrap\ 1283}# #{e\ 2530}#))
- (#{syntax-object-module\ 1284}# #{e\ 2530}#))
+ (if (#{syntax-object?\ 3779}# #{e\ 5369}#)
+ (#{match-each\ 5342}#
+ (#{syntax-object-expression\ 3780}# #{e\ 5369}#)
+ #{p\ 5370}#
+ (#{join-wraps\ 3814}#
+ #{w\ 5371}#
+ (#{syntax-object-wrap\ 3781}# #{e\ 5369}#))
+ (#{syntax-object-module\ 3782}# #{e\ 5369}#))
#f))))))
(set! $sc-dispatch
- (lambda (#{e\ 2536}# #{p\ 2537}#)
- (if (eq? #{p\ 2537}# (quote any))
- (list #{e\ 2536}#)
- (if (#{syntax-object?\ 1281}# #{e\ 2536}#)
- (#{match*\ 2506}#
- (#{syntax-object-expression\ 1282}# #{e\ 2536}#)
- #{p\ 2537}#
- (#{syntax-object-wrap\ 1283}# #{e\ 2536}#)
+ (lambda (#{e\ 5375}# #{p\ 5376}#)
+ (if (eq? #{p\ 5376}# (quote any))
+ (list #{e\ 5375}#)
+ (if (#{syntax-object?\ 3779}# #{e\ 5375}#)
+ (#{match*\ 5345}#
+ (#{syntax-object-expression\ 3780}# #{e\ 5375}#)
+ #{p\ 5376}#
+ (#{syntax-object-wrap\ 3781}# #{e\ 5375}#)
'()
- (#{syntax-object-module\ 1284}# #{e\ 2536}#))
- (#{match*\ 2506}#
- #{e\ 2536}#
- #{p\ 2537}#
+ (#{syntax-object-module\ 3782}# #{e\ 5375}#))
+ (#{match*\ 5345}#
+ #{e\ 5375}#
+ #{p\ 5376}#
'(())
'()
#f)))))))))
(define with-syntax
(make-syncase-macro
'macro
- (lambda (#{x\ 2538}#)
- ((lambda (#{tmp\ 2539}#)
- ((lambda (#{tmp\ 2540}#)
- (if #{tmp\ 2540}#
- (apply (lambda (#{_\ 2541}# #{e1\ 2542}# #{e2\ 2543}#)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(_ e1 e2)
- #((top) (top) (top))
- #("i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- (cons #{e1\ 2542}# #{e2\ 2543}#)))
- #{tmp\ 2540}#)
- ((lambda (#{tmp\ 2545}#)
- (if #{tmp\ 2545}#
- (apply (lambda (#{_\ 2546}#
- #{out\ 2547}#
- #{in\ 2548}#
- #{e1\ 2549}#
- #{e2\ 2550}#)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- #{in\ 2548}#
- '()
- (list #{out\ 2547}#
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile))
- (cons #{e1\ 2549}#
- #{e2\ 2550}#)))))
- #{tmp\ 2545}#)
- ((lambda (#{tmp\ 2552}#)
- (if #{tmp\ 2552}#
- (apply (lambda (#{_\ 2553}#
- #{out\ 2554}#
- #{in\ 2555}#
- #{e1\ 2556}#
- #{e2\ 2557}#)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- (cons '#(syntax-object
- list
+ (cons (lambda (#{x\ 5377}#)
+ ((lambda (#{tmp\ 5378}#)
+ ((lambda (#{tmp\ 5379}#)
+ (if #{tmp\ 5379}#
+ (apply (lambda (#{_\ 5380}# #{e1\ 5381}# #{e2\ 5382}#)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ e1 e2)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ (cons #{e1\ 5381}# #{e2\ 5382}#)))
+ #{tmp\ 5379}#)
+ ((lambda (#{tmp\ 5384}#)
+ (if #{tmp\ 5384}#
+ (apply (lambda (#{_\ 5385}#
+ #{out\ 5386}#
+ #{in\ 5387}#
+ #{e1\ 5388}#
+ #{e2\ 5389}#)
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ #{in\ 5387}#
+ '()
+ (list #{out\ 5386}#
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons #{e1\ 5388}#
+ #{e2\ 5389}#)))))
+ #{tmp\ 5384}#)
+ ((lambda (#{tmp\ 5391}#)
+ (if #{tmp\ 5391}#
+ (apply (lambda (#{_\ 5392}#
+ #{out\ 5393}#
+ #{in\ 5394}#
+ #{e1\ 5395}#
+ #{e2\ 5396}#)
+ (list '#(syntax-object
+ syntax-case
((top)
#(ribcage
#(_ out in e1 e2)
#((top))
#("i")))
(hygiene guile))
- #{in\ 2555}#)
- '()
- (list #{out\ 2554}#
(cons '#(syntax-object
- begin
+ list
((top)
#(ribcage
#(_ out in e1 e2)
#((top))
#("i")))
(hygiene guile))
- (cons #{e1\ 2556}#
- #{e2\ 2557}#)))))
- #{tmp\ 2552}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2539}#)))
- ($sc-dispatch
- #{tmp\ 2539}#
- '(any #(each (any any)) any . each-any)))))
- ($sc-dispatch
- #{tmp\ 2539}#
- '(any ((any any)) any . each-any)))))
- ($sc-dispatch
- #{tmp\ 2539}#
- '(any () any . each-any))))
- #{x\ 2538}#))))
+ #{in\ 5394}#)
+ '()
+ (list #{out\ 5393}#
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_
+ out
+ in
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons #{e1\ 5395}#
+ #{e2\ 5396}#)))))
+ #{tmp\ 5391}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5378}#)))
+ ($sc-dispatch
+ #{tmp\ 5378}#
+ '(any #(each (any any)) any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 5378}#
+ '(any ((any any)) any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 5378}#
+ '(any () any . each-any))))
+ #{x\ 5377}#))
+ (module-name (current-module)))))
(define syntax-rules
(make-syncase-macro
'macro
- (lambda (#{x\ 2561}#)
- ((lambda (#{tmp\ 2562}#)
- ((lambda (#{tmp\ 2563}#)
- (if #{tmp\ 2563}#
- (apply (lambda (#{_\ 2564}#
- #{k\ 2565}#
- #{keyword\ 2566}#
- #{pattern\ 2567}#
- #{template\ 2568}#)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile)))
- (cons '#(syntax-object
- syntax-case
+ (cons (lambda (#{x\ 5400}#)
+ ((lambda (#{tmp\ 5401}#)
+ ((lambda (#{tmp\ 5402}#)
+ (if #{tmp\ 5402}#
+ (apply (lambda (#{_\ 5403}#
+ #{k\ 5404}#
+ #{keyword\ 5405}#
+ #{pattern\ 5406}#
+ #{template\ 5407}#)
+ (list '#(syntax-object
+ lambda
((top)
#(ribcage
#(_ k keyword pattern template)
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile)))
(cons '#(syntax-object
- x
+ syntax-case
((top)
#(ribcage
#(_ k keyword pattern template)
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- (cons #{k\ 2565}#
- (map (lambda (#{tmp\ 2571}#
- #{tmp\ 2570}#)
- (list (cons '#(syntax-object
- dummy
- ((top)
- #(ribcage
- #(_
- k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- #{tmp\ 2570}#)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- #{tmp\ 2571}#)))
- #{template\ 2568}#
- #{pattern\ 2567}#))))))
- #{tmp\ 2563}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2562}#)))
- ($sc-dispatch
- #{tmp\ 2562}#
- '(any each-any . #(each ((any . any) any))))))
- #{x\ 2561}#))))
+ (cons '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons #{k\ 5404}#
+ (map (lambda (#{tmp\ 5410}#
+ #{tmp\ 5409}#)
+ (list (cons '#(syntax-object
+ dummy
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{tmp\ 5409}#)
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{tmp\ 5410}#)))
+ #{template\ 5407}#
+ #{pattern\ 5406}#))))))
+ #{tmp\ 5402}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5401}#)))
+ ($sc-dispatch
+ #{tmp\ 5401}#
+ '(any each-any . #(each ((any . any) any))))))
+ #{x\ 5400}#))
+ (module-name (current-module)))))
(define let*
(make-extended-syncase-macro
(module-ref (current-module) (quote let*))
'macro
- (lambda (#{x\ 2572}#)
- ((lambda (#{tmp\ 2573}#)
- ((lambda (#{tmp\ 2574}#)
- (if (if #{tmp\ 2574}#
- (apply (lambda (#{let*\ 2575}#
- #{x\ 2576}#
- #{v\ 2577}#
- #{e1\ 2578}#
- #{e2\ 2579}#)
- (and-map identifier? #{x\ 2576}#))
- #{tmp\ 2574}#)
- #f)
- (apply (lambda (#{let*\ 2581}#
- #{x\ 2582}#
- #{v\ 2583}#
- #{e1\ 2584}#
- #{e2\ 2585}#)
- (letrec ((#{f\ 2586}#
- (lambda (#{bindings\ 2587}#)
- (if (null? #{bindings\ 2587}#)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(f bindings)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(let* x v e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile))
- (cons '()
- (cons #{e1\ 2584}#
- #{e2\ 2585}#)))
- ((lambda (#{tmp\ 2591}#)
- ((lambda (#{tmp\ 2592}#)
- (if #{tmp\ 2592}#
- (apply (lambda (#{body\ 2593}#
- #{binding\ 2594}#)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(body
- binding)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- bindings)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- #(let*
- x
- v
- e1
- e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (list #{binding\ 2594}#)
- #{body\ 2593}#))
- #{tmp\ 2592}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2591}#)))
- ($sc-dispatch
- #{tmp\ 2591}#
- '(any any))))
- (list (#{f\ 2586}#
- (cdr #{bindings\ 2587}#))
- (car #{bindings\ 2587}#)))))))
- (#{f\ 2586}# (map list #{x\ 2582}# #{v\ 2583}#))))
- #{tmp\ 2574}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2573}#)))
- ($sc-dispatch
- #{tmp\ 2573}#
- '(any #(each (any any)) any . each-any))))
- #{x\ 2572}#))))
+ (cons (lambda (#{x\ 5411}#)
+ ((lambda (#{tmp\ 5412}#)
+ ((lambda (#{tmp\ 5413}#)
+ (if (if #{tmp\ 5413}#
+ (apply (lambda (#{let*\ 5414}#
+ #{x\ 5415}#
+ #{v\ 5416}#
+ #{e1\ 5417}#
+ #{e2\ 5418}#)
+ (and-map identifier? #{x\ 5415}#))
+ #{tmp\ 5413}#)
+ #f)
+ (apply (lambda (#{let*\ 5420}#
+ #{x\ 5421}#
+ #{v\ 5422}#
+ #{e1\ 5423}#
+ #{e2\ 5424}#)
+ (letrec ((#{f\ 5425}#
+ (lambda (#{bindings\ 5426}#)
+ (if (null? #{bindings\ 5426}#)
+ (cons '#(syntax-object
+ let
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(f bindings)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(let* x v e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons '()
+ (cons #{e1\ 5423}#
+ #{e2\ 5424}#)))
+ ((lambda (#{tmp\ 5430}#)
+ ((lambda (#{tmp\ 5431}#)
+ (if #{tmp\ 5431}#
+ (apply (lambda (#{body\ 5432}#
+ #{binding\ 5433}#)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(body
+ binding)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ bindings)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(let*
+ x
+ v
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (list #{binding\ 5433}#)
+ #{body\ 5432}#))
+ #{tmp\ 5431}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5430}#)))
+ ($sc-dispatch
+ #{tmp\ 5430}#
+ '(any any))))
+ (list (#{f\ 5425}#
+ (cdr #{bindings\ 5426}#))
+ (car #{bindings\ 5426}#)))))))
+ (#{f\ 5425}#
+ (map list #{x\ 5421}# #{v\ 5422}#))))
+ #{tmp\ 5413}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5412}#)))
+ ($sc-dispatch
+ #{tmp\ 5412}#
+ '(any #(each (any any)) any . each-any))))
+ #{x\ 5411}#))
+ (module-name (current-module)))))
(define do
- (make-extended-syncase-macro
- (module-ref (current-module) (quote do))
+ (make-syncase-macro
'macro
- (lambda (#{orig-x\ 2595}#)
- ((lambda (#{tmp\ 2596}#)
- ((lambda (#{tmp\ 2597}#)
- (if #{tmp\ 2597}#
- (apply (lambda (#{_\ 2598}#
- #{var\ 2599}#
- #{init\ 2600}#
- #{step\ 2601}#
- #{e0\ 2602}#
- #{e1\ 2603}#
- #{c\ 2604}#)
- ((lambda (#{tmp\ 2605}#)
- ((lambda (#{tmp\ 2606}#)
- (if #{tmp\ 2606}#
- (apply (lambda (#{step\ 2607}#)
- ((lambda (#{tmp\ 2608}#)
- ((lambda (#{tmp\ 2609}#)
- (if #{tmp\ 2609}#
- (apply (lambda ()
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (map list
- #{var\ 2599}#
- #{init\ 2600}#)
+ (cons (lambda (#{orig-x\ 5434}#)
+ ((lambda (#{tmp\ 5435}#)
+ ((lambda (#{tmp\ 5436}#)
+ (if #{tmp\ 5436}#
+ (apply (lambda (#{_\ 5437}#
+ #{var\ 5438}#
+ #{init\ 5439}#
+ #{step\ 5440}#
+ #{e0\ 5441}#
+ #{e1\ 5442}#
+ #{c\ 5443}#)
+ ((lambda (#{tmp\ 5444}#)
+ ((lambda (#{tmp\ 5445}#)
+ (if #{tmp\ 5445}#
+ (apply (lambda (#{step\ 5446}#)
+ ((lambda (#{tmp\ 5447}#)
+ ((lambda (#{tmp\ 5448}#)
+ (if #{tmp\ 5448}#
+ (apply (lambda ()
(list '#(syntax-object
- if
+ let
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ '#(syntax-object
+ doloop
((top)
#(ribcage
#(step)
#("i")))
(hygiene
guile))
+ (map list
+ #{var\ 5438}#
+ #{init\ 5439}#)
(list '#(syntax-object
- not
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- #{e0\ 2602}#)
- (cons '#(syntax-object
- begin
+ if
((top)
#(ribcage
#(step)
init
step
e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (append
- #{c\ 2604}#
- (list (cons '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- #{step\ 2607}#)))))))
- #{tmp\ 2609}#)
- ((lambda (#{tmp\ 2614}#)
- (if #{tmp\ 2614}#
- (apply (lambda (#{e1\ 2615}#
- #{e2\ 2616}#)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (map list
- #{var\ 2599}#
- #{init\ 2600}#)
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (list '#(syntax-object
+ not
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{e0\ 5441}#)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (append
+ #{c\ 5443}#
+ (list (cons '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{step\ 5446}#)))))))
+ #{tmp\ 5448}#)
+ ((lambda (#{tmp\ 5453}#)
+ (if #{tmp\ 5453}#
+ (apply (lambda (#{e1\ 5454}#
+ #{e2\ 5455}#)
(list '#(syntax-object
- if
+ let
((top)
#(ribcage
#(e1
#("i")))
(hygiene
guile))
- #{e0\ 2602}#
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (cons #{e1\ 2615}#
- #{e2\ 2616}#))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (append
- #{c\ 2604}#
- (list (cons '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i")))
- (hygiene
- guile))
- #{step\ 2607}#)))))))
- #{tmp\ 2614}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2608}#)))
- ($sc-dispatch
- #{tmp\ 2608}#
- '(any . each-any)))))
- ($sc-dispatch
- #{tmp\ 2608}#
- '())))
- #{e1\ 2603}#))
- #{tmp\ 2606}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2605}#)))
- ($sc-dispatch #{tmp\ 2605}# (quote each-any))))
- (map (lambda (#{v\ 2623}# #{s\ 2624}#)
- ((lambda (#{tmp\ 2625}#)
- ((lambda (#{tmp\ 2626}#)
- (if #{tmp\ 2626}#
- (apply (lambda () #{v\ 2623}#)
- #{tmp\ 2626}#)
- ((lambda (#{tmp\ 2627}#)
- (if #{tmp\ 2627}#
- (apply (lambda (#{e\ 2628}#)
- #{e\ 2628}#)
- #{tmp\ 2627}#)
- ((lambda (#{_\ 2629}#)
- (syntax-violation
- 'do
- "bad step expression"
- #{orig-x\ 2595}#
- #{s\ 2624}#))
- #{tmp\ 2625}#)))
- ($sc-dispatch
- #{tmp\ 2625}#
- '(any)))))
- ($sc-dispatch #{tmp\ 2625}# (quote ()))))
- #{s\ 2624}#))
- #{var\ 2599}#
- #{step\ 2601}#)))
- #{tmp\ 2597}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2596}#)))
- ($sc-dispatch
- #{tmp\ 2596}#
- '(any #(each (any any . any))
- (any . each-any)
- .
- each-any))))
- #{orig-x\ 2595}#))))
-
-(define quasiquote
- (make-extended-syncase-macro
- (module-ref (current-module) (quote quasiquote))
- 'macro
- (letrec ((#{quasicons\ 2632}#
- (lambda (#{x\ 2636}# #{y\ 2637}#)
- ((lambda (#{tmp\ 2638}#)
- ((lambda (#{tmp\ 2639}#)
- (if #{tmp\ 2639}#
- (apply (lambda (#{x\ 2640}# #{y\ 2641}#)
- ((lambda (#{tmp\ 2642}#)
- ((lambda (#{tmp\ 2643}#)
- (if #{tmp\ 2643}#
- (apply (lambda (#{dy\ 2644}#)
- ((lambda (#{tmp\ 2645}#)
- ((lambda (#{tmp\ 2646}#)
- (if #{tmp\ 2646}#
- (apply (lambda (#{dx\ 2647}#)
- (list '#(syntax-object
- quote
+ '#(syntax-object
+ doloop
((top)
#(ribcage
- #(dx)
- #((top))
- #("i"))
- #(ribcage
- #(dy)
- #((top))
- #("i"))
- #(ribcage
- #(x
- y)
+ #(e1
+ e2)
#((top)
(top))
#("i"
"i"))
#(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
+ #(step)
+ #((top))
+ #("i"))
#(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
#((top)
+ (top)
+ (top)
+ (top)
(top)
(top)
(top))
#("i"
"i"
"i"
- "i")))
- (hygiene
- guile))
- (cons #{dx\ 2647}#
- #{dy\ 2644}#)))
- #{tmp\ 2646}#)
- ((lambda (#{_\ 2648}#)
- (if (null? #{dy\ 2644}#)
- (list '#(syntax-object
- list
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(dy)
- #((top))
- #("i"))
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i")))
- (hygiene
- guile))
- #{x\ 2640}#)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(dy)
- #((top))
- #("i"))
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i")))
- (hygiene
- guile))
- #{x\ 2640}#
- #{y\ 2641}#)))
- #{tmp\ 2645}#)))
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (map list
+ #{var\ 5438}#
+ #{init\ 5439}#)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{e0\ 5441}#
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (cons #{e1\ 5454}#
+ #{e2\ 5455}#))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (append
+ #{c\ 5443}#
+ (list (cons '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{step\ 5446}#)))))))
+ #{tmp\ 5453}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5447}#)))
($sc-dispatch
- #{tmp\ 2645}#
- '(#(free-id
- #(syntax-object
- quote
- ((top)
- #(ribcage
- #(dy)
- #((top))
- #("i"))
- #(ribcage
- #(x y)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x y)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i")))
- (hygiene
- guile)))
- any))))
- #{x\ 2640}#))
- #{tmp\ 2643}#)
- ((lambda (#{tmp\ 2649}#)
- (if #{tmp\ 2649}#
- (apply (lambda (#{stuff\ 2650}#)
- (cons '#(syntax-object
- list
+ #{tmp\ 5447}#
+ '(any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 5447}#
+ '())))
+ #{e1\ 5442}#))
+ #{tmp\ 5445}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5444}#)))
+ ($sc-dispatch
+ #{tmp\ 5444}#
+ 'each-any)))
+ (map (lambda (#{v\ 5462}# #{s\ 5463}#)
+ ((lambda (#{tmp\ 5464}#)
+ ((lambda (#{tmp\ 5465}#)
+ (if #{tmp\ 5465}#
+ (apply (lambda () #{v\ 5462}#)
+ #{tmp\ 5465}#)
+ ((lambda (#{tmp\ 5466}#)
+ (if #{tmp\ 5466}#
+ (apply (lambda (#{e\ 5467}#)
+ #{e\ 5467}#)
+ #{tmp\ 5466}#)
+ ((lambda (#{_\ 5468}#)
+ (syntax-violation
+ 'do
+ "bad step expression"
+ #{orig-x\ 5434}#
+ #{s\ 5463}#))
+ #{tmp\ 5464}#)))
+ ($sc-dispatch
+ #{tmp\ 5464}#
+ '(any)))))
+ ($sc-dispatch
+ #{tmp\ 5464}#
+ '())))
+ #{s\ 5463}#))
+ #{var\ 5438}#
+ #{step\ 5440}#)))
+ #{tmp\ 5436}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5435}#)))
+ ($sc-dispatch
+ #{tmp\ 5435}#
+ '(any #(each (any any . any))
+ (any . each-any)
+ .
+ each-any))))
+ #{orig-x\ 5434}#))
+ (module-name (current-module)))))
+
+(define quasiquote
+ (make-syncase-macro
+ 'macro
+ (cons (letrec ((#{quasicons\ 5471}#
+ (lambda (#{x\ 5475}# #{y\ 5476}#)
+ ((lambda (#{tmp\ 5477}#)
+ ((lambda (#{tmp\ 5478}#)
+ (if #{tmp\ 5478}#
+ (apply (lambda (#{x\ 5479}# #{y\ 5480}#)
+ ((lambda (#{tmp\ 5481}#)
+ ((lambda (#{tmp\ 5482}#)
+ (if #{tmp\ 5482}#
+ (apply (lambda (#{dy\ 5483}#)
+ ((lambda (#{tmp\ 5484}#)
+ ((lambda (#{tmp\ 5485}#)
+ (if #{tmp\ 5485}#
+ (apply (lambda (#{dx\ 5486}#)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(dx)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(dy)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile))
+ (cons #{dx\ 5486}#
+ #{dy\ 5483}#)))
+ #{tmp\ 5485}#)
+ ((lambda (#{_\ 5487}#)
+ (if (null? #{dy\ 5483}#)
+ (list '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(dy)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile))
+ #{x\ 5479}#)
+ (list '#(syntax-object
+ cons
+ ((top)
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(dy)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile))
+ #{x\ 5479}#
+ #{y\ 5480}#)))
+ #{tmp\ 5484}#)))
+ ($sc-dispatch
+ #{tmp\ 5484}#
+ '(#(free-id
+ #(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(dy)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile)))
+ any))))
+ #{x\ 5479}#))
+ #{tmp\ 5482}#)
+ ((lambda (#{tmp\ 5488}#)
+ (if #{tmp\ 5488}#
+ (apply (lambda (#{stuff\ 5489}#)
+ (cons '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(stuff)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile))
+ (cons #{x\ 5479}#
+ #{stuff\ 5489}#)))
+ #{tmp\ 5488}#)
+ ((lambda (#{else\ 5490}#)
+ (list '#(syntax-object
+ cons
((top)
#(ribcage
- #(stuff)
+ #(else)
#((top))
#("i"))
#(ribcage
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
- (hygiene
- guile))
- (cons #{x\ 2640}#
- #{stuff\ 2650}#)))
- #{tmp\ 2649}#)
- ((lambda (#{else\ 2651}#)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage
- #(else)
- #((top))
- #("i"))
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i")))
- (hygiene guile))
- #{x\ 2640}#
- #{y\ 2641}#))
- #{tmp\ 2642}#)))
- ($sc-dispatch
- #{tmp\ 2642}#
- '(#(free-id
- #(syntax-object
- list
- ((top)
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- .
- any)))))
- ($sc-dispatch
- #{tmp\ 2642}#
- '(#(free-id
- #(syntax-object
- quote
- ((top)
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- any))))
- #{y\ 2641}#))
- #{tmp\ 2639}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2638}#)))
- ($sc-dispatch #{tmp\ 2638}# (quote (any any)))))
- (list #{x\ 2636}# #{y\ 2637}#))))
- (#{quasiappend\ 2633}#
- (lambda (#{x\ 2652}# #{y\ 2653}#)
- ((lambda (#{tmp\ 2654}#)
- ((lambda (#{tmp\ 2655}#)
- (if #{tmp\ 2655}#
- (apply (lambda (#{x\ 2656}# #{y\ 2657}#)
- ((lambda (#{tmp\ 2658}#)
- ((lambda (#{tmp\ 2659}#)
- (if #{tmp\ 2659}#
- (apply (lambda () #{x\ 2656}#)
- #{tmp\ 2659}#)
- ((lambda (#{_\ 2660}#)
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile))
+ #{x\ 5479}#
+ #{y\ 5480}#))
+ #{tmp\ 5481}#)))
+ ($sc-dispatch
+ #{tmp\ 5481}#
+ '(#(free-id
+ #(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene guile)))
+ .
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 5481}#
+ '(#(free-id
+ #(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile)))
+ any))))
+ #{y\ 5480}#))
+ #{tmp\ 5478}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5477}#)))
+ ($sc-dispatch #{tmp\ 5477}# (quote (any any)))))
+ (list #{x\ 5475}# #{y\ 5476}#))))
+ (#{quasiappend\ 5472}#
+ (lambda (#{x\ 5491}# #{y\ 5492}#)
+ ((lambda (#{tmp\ 5493}#)
+ ((lambda (#{tmp\ 5494}#)
+ (if #{tmp\ 5494}#
+ (apply (lambda (#{x\ 5495}# #{y\ 5496}#)
+ ((lambda (#{tmp\ 5497}#)
+ ((lambda (#{tmp\ 5498}#)
+ (if #{tmp\ 5498}#
+ (apply (lambda () #{x\ 5495}#)
+ #{tmp\ 5498}#)
+ ((lambda (#{_\ 5499}#)
+ (list '#(syntax-object
+ append
+ ((top)
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene guile))
+ #{x\ 5495}#
+ #{y\ 5496}#))
+ #{tmp\ 5497}#)))
+ ($sc-dispatch
+ #{tmp\ 5497}#
+ '(#(free-id
+ #(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile)))
+ ()))))
+ #{y\ 5496}#))
+ #{tmp\ 5494}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5493}#)))
+ ($sc-dispatch #{tmp\ 5493}# (quote (any any)))))
+ (list #{x\ 5491}# #{y\ 5492}#))))
+ (#{quasivector\ 5473}#
+ (lambda (#{x\ 5500}#)
+ ((lambda (#{tmp\ 5501}#)
+ ((lambda (#{x\ 5502}#)
+ ((lambda (#{tmp\ 5503}#)
+ ((lambda (#{tmp\ 5504}#)
+ (if #{tmp\ 5504}#
+ (apply (lambda (#{x\ 5505}#)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile))
+ (list->vector
+ #{x\ 5505}#)))
+ #{tmp\ 5504}#)
+ ((lambda (#{tmp\ 5507}#)
+ (if #{tmp\ 5507}#
+ (apply (lambda (#{x\ 5508}#)
+ (cons '#(syntax-object
+ vector
+ ((top)
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene guile))
+ #{x\ 5508}#))
+ #{tmp\ 5507}#)
+ ((lambda (#{_\ 5510}#)
(list '#(syntax-object
- append
+ list->vector
((top)
#(ribcage
#(_)
#((top))
#("i"))
#(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
+ #(x)
+ #((top))
+ #("i"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
+ #(x)
+ #((top))
+ #("i"))
#(ribcage
#(quasicons
quasiappend
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- #{x\ 2656}#
- #{y\ 2657}#))
- #{tmp\ 2658}#)))
+ #{x\ 5502}#))
+ #{tmp\ 5503}#)))
($sc-dispatch
- #{tmp\ 2658}#
+ #{tmp\ 5503}#
'(#(free-id
#(syntax-object
- quote
+ list
((top)
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
+ #(ribcage #(x) #((top)) #("i"))
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
+ #(ribcage #(x) #((top)) #("i"))
#(ribcage
#(quasicons
quasiappend
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile)))
- ()))))
- #{y\ 2657}#))
- #{tmp\ 2655}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2654}#)))
- ($sc-dispatch #{tmp\ 2654}# (quote (any any)))))
- (list #{x\ 2652}# #{y\ 2653}#))))
- (#{quasivector\ 2634}#
- (lambda (#{x\ 2661}#)
- ((lambda (#{tmp\ 2662}#)
- ((lambda (#{x\ 2663}#)
- ((lambda (#{tmp\ 2664}#)
- ((lambda (#{tmp\ 2665}#)
- (if #{tmp\ 2665}#
- (apply (lambda (#{x\ 2666}#)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile))
- (list->vector #{x\ 2666}#)))
- #{tmp\ 2665}#)
- ((lambda (#{tmp\ 2668}#)
- (if #{tmp\ 2668}#
- (apply (lambda (#{x\ 2669}#)
- (cons '#(syntax-object
- vector
- ((top)
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i")))
- (hygiene guile))
- #{x\ 2669}#))
- #{tmp\ 2668}#)
- ((lambda (#{_\ 2671}#)
- (list '#(syntax-object
- list->vector
+ .
+ each-any)))))
+ ($sc-dispatch
+ #{tmp\ 5503}#
+ '(#(free-id
+ #(syntax-object
+ quote
+ ((top)
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile)))
+ each-any))))
+ #{x\ 5502}#))
+ #{tmp\ 5501}#))
+ #{x\ 5500}#)))
+ (#{quasi\ 5474}#
+ (lambda (#{p\ 5511}# #{lev\ 5512}#)
+ ((lambda (#{tmp\ 5513}#)
+ ((lambda (#{tmp\ 5514}#)
+ (if #{tmp\ 5514}#
+ (apply (lambda (#{p\ 5515}#)
+ (if (= #{lev\ 5512}# 0)
+ #{p\ 5515}#
+ (#{quasicons\ 5471}#
+ '(#(syntax-object
+ quote
((top)
#(ribcage
- #(_)
+ #(p)
#((top))
#("i"))
+ #(ribcage () () ())
#(ribcage
- #(x)
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile))
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage
+ #(p)
#((top))
#("i"))
#(ribcage () () ())
- #(ribcage () () ())
#(ribcage
- #(x)
- #((top))
- #("i"))
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
#(ribcage
#(quasicons
quasiappend
quasi)
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
- (hygiene guile))
- #{x\ 2663}#))
- #{tmp\ 2664}#)))
- ($sc-dispatch
- #{tmp\ 2664}#
- '(#(free-id
- #(syntax-object
- list
- ((top)
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- .
- each-any)))))
- ($sc-dispatch
- #{tmp\ 2664}#
- '(#(free-id
- #(syntax-object
- quote
- ((top)
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- each-any))))
- #{x\ 2663}#))
- #{tmp\ 2662}#))
- #{x\ 2661}#)))
- (#{quasi\ 2635}#
- (lambda (#{p\ 2672}# #{lev\ 2673}#)
- ((lambda (#{tmp\ 2674}#)
- ((lambda (#{tmp\ 2675}#)
- (if #{tmp\ 2675}#
- (apply (lambda (#{p\ 2676}#)
- (if (= #{lev\ 2673}# 0)
- #{p\ 2676}#
- (#{quasicons\ 2632}#
- '(#(syntax-object
- quote
- ((top)
- #(ribcage #(p) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile))
- #(syntax-object
- unquote
- ((top)
- #(ribcage #(p) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- (#{quasi\ 2635}#
- (list #{p\ 2676}#)
- (- #{lev\ 2673}# 1)))))
- #{tmp\ 2675}#)
- ((lambda (#{tmp\ 2677}#)
- (if (if #{tmp\ 2677}#
- (apply (lambda (#{args\ 2678}#)
- (= #{lev\ 2673}# 0))
- #{tmp\ 2677}#)
- #f)
- (apply (lambda (#{args\ 2679}#)
- (syntax-violation
- 'unquote
- "unquote takes exactly one argument"
- #{p\ 2672}#
- (cons '#(syntax-object
- unquote
- ((top)
- #(ribcage
- #(args)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile))
- #{args\ 2679}#)))
- #{tmp\ 2677}#)
- ((lambda (#{tmp\ 2680}#)
- (if #{tmp\ 2680}#
- (apply (lambda (#{p\ 2681}# #{q\ 2682}#)
- (if (= #{lev\ 2673}# 0)
- (#{quasiappend\ 2633}#
- #{p\ 2681}#
- (#{quasi\ 2635}#
- #{q\ 2682}#
- #{lev\ 2673}#))
- (#{quasicons\ 2632}#
- (#{quasicons\ 2632}#
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i")))
- (hygiene guile))
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- (#{quasi\ 2635}#
- (list #{p\ 2681}#)
- (- #{lev\ 2673}# 1)))
- (#{quasi\ 2635}#
- #{q\ 2682}#
- #{lev\ 2673}#))))
- #{tmp\ 2680}#)
- ((lambda (#{tmp\ 2683}#)
- (if (if #{tmp\ 2683}#
- (apply (lambda (#{args\ 2684}#
- #{q\ 2685}#)
- (= #{lev\ 2673}# 0))
- #{tmp\ 2683}#)
- #f)
- (apply (lambda (#{args\ 2686}#
- #{q\ 2687}#)
- (syntax-violation
- 'unquote-splicing
- "unquote-splicing takes exactly one argument"
- #{p\ 2672}#
- (cons '#(syntax-object
- unquote-splicing
+ (hygiene guile)))
+ (#{quasi\ 5474}#
+ (list #{p\ 5515}#)
+ (- #{lev\ 5512}# 1)))))
+ #{tmp\ 5514}#)
+ ((lambda (#{tmp\ 5516}#)
+ (if (if #{tmp\ 5516}#
+ (apply (lambda (#{args\ 5517}#)
+ (= #{lev\ 5512}# 0))
+ #{tmp\ 5516}#)
+ #f)
+ (apply (lambda (#{args\ 5518}#)
+ (syntax-violation
+ 'unquote
+ "unquote takes exactly one argument"
+ #{p\ 5511}#
+ (cons '#(syntax-object
+ unquote
+ ((top)
+ #(ribcage
+ #(args)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile))
+ #{args\ 5518}#)))
+ #{tmp\ 5516}#)
+ ((lambda (#{tmp\ 5519}#)
+ (if #{tmp\ 5519}#
+ (apply (lambda (#{p\ 5520}#
+ #{q\ 5521}#)
+ (if (= #{lev\ 5512}# 0)
+ (#{quasiappend\ 5472}#
+ #{p\ 5520}#
+ (#{quasi\ 5474}#
+ #{q\ 5521}#
+ #{lev\ 5512}#))
+ (#{quasicons\ 5471}#
+ (#{quasicons\ 5471}#
+ '(#(syntax-object
+ quote
((top)
#(ribcage
- #(args q)
+ #(p q)
#((top) (top))
#("i" "i"))
#(ribcage
"i"
"i")))
(hygiene guile))
- #{args\ 2686}#)))
- #{tmp\ 2683}#)
- ((lambda (#{tmp\ 2688}#)
- (if #{tmp\ 2688}#
- (apply (lambda (#{p\ 2689}#)
- (#{quasicons\ 2632}#
- '(#(syntax-object
- quote
+ #(syntax-object
+ unquote-splicing
((top)
#(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(p lev)
+ #(p q)
#((top) (top))
#("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i")))
- (hygiene guile))
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
#(ribcage
()
()
"i"
"i")))
(hygiene guile)))
- (#{quasi\ 2635}#
- (list #{p\ 2689}#)
- (+ #{lev\ 2673}#
- 1))))
- #{tmp\ 2688}#)
- ((lambda (#{tmp\ 2690}#)
- (if #{tmp\ 2690}#
- (apply (lambda (#{p\ 2691}#
- #{q\ 2692}#)
- (#{quasicons\ 2632}#
- (#{quasi\ 2635}#
- #{p\ 2691}#
- #{lev\ 2673}#)
- (#{quasi\ 2635}#
- #{q\ 2692}#
- #{lev\ 2673}#)))
- #{tmp\ 2690}#)
- ((lambda (#{tmp\ 2693}#)
- (if #{tmp\ 2693}#
- (apply (lambda (#{x\ 2694}#)
- (#{quasivector\ 2634}#
- (#{quasi\ 2635}#
- #{x\ 2694}#
- #{lev\ 2673}#)))
- #{tmp\ 2693}#)
- ((lambda (#{p\ 2696}#)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(p lev)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i")))
- (hygiene
- guile))
- #{p\ 2696}#))
- #{tmp\ 2674}#)))
- ($sc-dispatch
- #{tmp\ 2674}#
- '#(vector each-any)))))
- ($sc-dispatch
- #{tmp\ 2674}#
- '(any . any)))))
- ($sc-dispatch
- #{tmp\ 2674}#
- '(#(free-id
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- any)))))
- ($sc-dispatch
- #{tmp\ 2674}#
- '((#(free-id
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons
- quasiappend
- quasivector
- quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
+ (#{quasi\ 5474}#
+ (list #{p\ 5520}#)
+ (- #{lev\ 5512}# 1)))
+ (#{quasi\ 5474}#
+ #{q\ 5521}#
+ #{lev\ 5512}#))))
+ #{tmp\ 5519}#)
+ ((lambda (#{tmp\ 5522}#)
+ (if (if #{tmp\ 5522}#
+ (apply (lambda (#{args\ 5523}#
+ #{q\ 5524}#)
+ (= #{lev\ 5512}# 0))
+ #{tmp\ 5522}#)
+ #f)
+ (apply (lambda (#{args\ 5525}#
+ #{q\ 5526}#)
+ (syntax-violation
+ 'unquote-splicing
+ "unquote-splicing takes exactly one argument"
+ #{p\ 5511}#
+ (cons '#(syntax-object
+ unquote-splicing
+ ((top)
+ #(ribcage
+ #(args q)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(p lev)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile))
+ #{args\ 5525}#)))
+ #{tmp\ 5522}#)
+ ((lambda (#{tmp\ 5527}#)
+ (if #{tmp\ 5527}#
+ (apply (lambda (#{p\ 5528}#)
+ (#{quasicons\ 5471}#
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(p lev)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile))
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(p lev)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile)))
+ (#{quasi\ 5474}#
+ (list #{p\ 5528}#)
+ (+ #{lev\ 5512}#
+ 1))))
+ #{tmp\ 5527}#)
+ ((lambda (#{tmp\ 5529}#)
+ (if #{tmp\ 5529}#
+ (apply (lambda (#{p\ 5530}#
+ #{q\ 5531}#)
+ (#{quasicons\ 5471}#
+ (#{quasi\ 5474}#
+ #{p\ 5530}#
+ #{lev\ 5512}#)
+ (#{quasi\ 5474}#
+ #{q\ 5531}#
+ #{lev\ 5512}#)))
+ #{tmp\ 5529}#)
+ ((lambda (#{tmp\ 5532}#)
+ (if #{tmp\ 5532}#
+ (apply (lambda (#{x\ 5533}#)
+ (#{quasivector\ 5473}#
+ (#{quasi\ 5474}#
+ #{x\ 5533}#
+ #{lev\ 5512}#)))
+ #{tmp\ 5532}#)
+ ((lambda (#{p\ 5535}#)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(p
+ lev)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene
+ guile))
+ #{p\ 5535}#))
+ #{tmp\ 5513}#)))
+ ($sc-dispatch
+ #{tmp\ 5513}#
+ '#(vector
+ each-any)))))
+ ($sc-dispatch
+ #{tmp\ 5513}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 5513}#
+ '(#(free-id
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile)))
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 5513}#
+ '((#(free-id
+ #(syntax-object
+ unquote-splicing
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile)))
+ .
+ any)
+ .
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 5513}#
+ '((#(free-id
+ #(syntax-object
+ unquote-splicing
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile)))
+ any)
.
- any)
- .
- any)))))
- ($sc-dispatch
- #{tmp\ 2674}#
- '((#(free-id
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 5513}#
+ '(#(free-id
#(syntax-object
- unquote-splicing
+ unquote
((top)
#(ribcage () () ())
#(ribcage
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile)))
- any)
- .
- any)))))
- ($sc-dispatch
- #{tmp\ 2674}#
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(quasicons quasiappend quasivector quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- .
- any)))))
- ($sc-dispatch
- #{tmp\ 2674}#
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage () () ())
- #(ribcage #(p lev) #((top) (top)) #("i" "i"))
- #(ribcage
- #(quasicons quasiappend quasivector quasi)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i")))
- (hygiene guile)))
- any))))
- #{p\ 2672}#))))
- (lambda (#{x\ 2697}#)
- ((lambda (#{tmp\ 2698}#)
- ((lambda (#{tmp\ 2699}#)
- (if #{tmp\ 2699}#
- (apply (lambda (#{_\ 2700}# #{e\ 2701}#)
- (#{quasi\ 2635}# #{e\ 2701}# 0))
- #{tmp\ 2699}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2698}#)))
- ($sc-dispatch #{tmp\ 2698}# (quote (any any)))))
- #{x\ 2697}#)))))
+ .
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 5513}#
+ '(#(free-id
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i")))
+ (hygiene guile)))
+ any))))
+ #{p\ 5511}#))))
+ (lambda (#{x\ 5536}#)
+ ((lambda (#{tmp\ 5537}#)
+ ((lambda (#{tmp\ 5538}#)
+ (if #{tmp\ 5538}#
+ (apply (lambda (#{_\ 5539}# #{e\ 5540}#)
+ (#{quasi\ 5474}# #{e\ 5540}# 0))
+ #{tmp\ 5538}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5537}#)))
+ ($sc-dispatch #{tmp\ 5537}# (quote (any any)))))
+ #{x\ 5536}#)))
+ (module-name (current-module)))))
(define include
(make-syncase-macro
'macro
- (lambda (#{x\ 2702}#)
- (letrec ((#{read-file\ 2703}#
- (lambda (#{fn\ 2704}# #{k\ 2705}#)
- (let ((#{p\ 2706}# (open-input-file #{fn\ 2704}#)))
- (letrec ((#{f\ 2707}#
- (lambda (#{x\ 2708}#)
- (if (eof-object? #{x\ 2708}#)
- (begin
- (close-input-port #{p\ 2706}#)
- '())
- (cons (datum->syntax
- #{k\ 2705}#
- #{x\ 2708}#)
- (#{f\ 2707}# (read #{p\ 2706}#)))))))
- (#{f\ 2707}# (read #{p\ 2706}#)))))))
- ((lambda (#{tmp\ 2709}#)
- ((lambda (#{tmp\ 2710}#)
- (if #{tmp\ 2710}#
- (apply (lambda (#{k\ 2711}# #{filename\ 2712}#)
- (let ((#{fn\ 2713}#
- (syntax->datum #{filename\ 2712}#)))
- ((lambda (#{tmp\ 2714}#)
- ((lambda (#{tmp\ 2715}#)
- (if #{tmp\ 2715}#
- (apply (lambda (#{exp\ 2716}#)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(exp)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(fn)
- #((top))
- #("i"))
- #(ribcage
- #(k filename)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- (read-file)
- ((top))
- ("i"))
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile))
- #{exp\ 2716}#))
- #{tmp\ 2715}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2714}#)))
- ($sc-dispatch #{tmp\ 2714}# (quote each-any))))
- (#{read-file\ 2703}# #{fn\ 2713}# #{k\ 2711}#))))
- #{tmp\ 2710}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2709}#)))
- ($sc-dispatch #{tmp\ 2709}# (quote (any any)))))
- #{x\ 2702}#)))))
+ (cons (lambda (#{x\ 5541}#)
+ (letrec ((#{read-file\ 5542}#
+ (lambda (#{fn\ 5543}# #{k\ 5544}#)
+ (let ((#{p\ 5545}# (open-input-file #{fn\ 5543}#)))
+ (letrec ((#{f\ 5546}#
+ (lambda (#{x\ 5547}#)
+ (if (eof-object? #{x\ 5547}#)
+ (begin
+ (close-input-port #{p\ 5545}#)
+ '())
+ (cons (datum->syntax
+ #{k\ 5544}#
+ #{x\ 5547}#)
+ (#{f\ 5546}#
+ (read #{p\ 5545}#)))))))
+ (#{f\ 5546}# (read #{p\ 5545}#)))))))
+ ((lambda (#{tmp\ 5548}#)
+ ((lambda (#{tmp\ 5549}#)
+ (if #{tmp\ 5549}#
+ (apply (lambda (#{k\ 5550}# #{filename\ 5551}#)
+ (let ((#{fn\ 5552}#
+ (syntax->datum #{filename\ 5551}#)))
+ ((lambda (#{tmp\ 5553}#)
+ ((lambda (#{tmp\ 5554}#)
+ (if #{tmp\ 5554}#
+ (apply (lambda (#{exp\ 5555}#)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(exp)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(fn)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(k filename)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ (read-file)
+ ((top))
+ ("i"))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #{exp\ 5555}#))
+ #{tmp\ 5554}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5553}#)))
+ ($sc-dispatch
+ #{tmp\ 5553}#
+ 'each-any)))
+ (#{read-file\ 5542}#
+ #{fn\ 5552}#
+ #{k\ 5550}#))))
+ #{tmp\ 5549}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5548}#)))
+ ($sc-dispatch #{tmp\ 5548}# (quote (any any)))))
+ #{x\ 5541}#)))
+ (module-name (current-module)))))
+
+(define include-from-path
+ (make-syncase-macro
+ 'macro
+ (cons (lambda (#{x\ 5557}#)
+ ((lambda (#{tmp\ 5558}#)
+ ((lambda (#{tmp\ 5559}#)
+ (if #{tmp\ 5559}#
+ (apply (lambda (#{k\ 5560}# #{filename\ 5561}#)
+ (let ((#{fn\ 5562}#
+ (syntax->datum #{filename\ 5561}#)))
+ ((lambda (#{tmp\ 5563}#)
+ ((lambda (#{fn\ 5564}#)
+ (list '#(syntax-object
+ include
+ ((top)
+ #(ribcage #(fn) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(fn) #((top)) #("i"))
+ #(ribcage
+ #(k filename)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ #{fn\ 5564}#))
+ #{tmp\ 5563}#))
+ (let ((#{t\ 5565}#
+ (%search-load-path #{fn\ 5562}#)))
+ (if #{t\ 5565}#
+ #{t\ 5565}#
+ (syntax-violation
+ 'include-from-path
+ "file not found in path"
+ #{x\ 5557}#
+ #{filename\ 5561}#))))))
+ #{tmp\ 5559}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5558}#)))
+ ($sc-dispatch #{tmp\ 5558}# (quote (any any)))))
+ #{x\ 5557}#))
+ (module-name (current-module)))))
(define unquote
(make-syncase-macro
'macro
- (lambda (#{x\ 2718}#)
- ((lambda (#{tmp\ 2719}#)
- ((lambda (#{tmp\ 2720}#)
- (if #{tmp\ 2720}#
- (apply (lambda (#{_\ 2721}# #{e\ 2722}#)
- (syntax-violation
- 'unquote
- "expression not valid outside of quasiquote"
- #{x\ 2718}#))
- #{tmp\ 2720}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2719}#)))
- ($sc-dispatch #{tmp\ 2719}# (quote (any any)))))
- #{x\ 2718}#))))
+ (cons (lambda (#{x\ 5566}#)
+ ((lambda (#{tmp\ 5567}#)
+ ((lambda (#{tmp\ 5568}#)
+ (if #{tmp\ 5568}#
+ (apply (lambda (#{_\ 5569}# #{e\ 5570}#)
+ (syntax-violation
+ 'unquote
+ "expression not valid outside of quasiquote"
+ #{x\ 5566}#))
+ #{tmp\ 5568}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5567}#)))
+ ($sc-dispatch #{tmp\ 5567}# (quote (any any)))))
+ #{x\ 5566}#))
+ (module-name (current-module)))))
(define unquote-splicing
(make-syncase-macro
'macro
- (lambda (#{x\ 2723}#)
- ((lambda (#{tmp\ 2724}#)
- ((lambda (#{tmp\ 2725}#)
- (if #{tmp\ 2725}#
- (apply (lambda (#{_\ 2726}# #{e\ 2727}#)
- (syntax-violation
- 'unquote-splicing
- "expression not valid outside of quasiquote"
- #{x\ 2723}#))
- #{tmp\ 2725}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2724}#)))
- ($sc-dispatch #{tmp\ 2724}# (quote (any any)))))
- #{x\ 2723}#))))
+ (cons (lambda (#{x\ 5571}#)
+ ((lambda (#{tmp\ 5572}#)
+ ((lambda (#{tmp\ 5573}#)
+ (if #{tmp\ 5573}#
+ (apply (lambda (#{_\ 5574}# #{e\ 5575}#)
+ (syntax-violation
+ 'unquote-splicing
+ "expression not valid outside of quasiquote"
+ #{x\ 5571}#))
+ #{tmp\ 5573}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5572}#)))
+ ($sc-dispatch #{tmp\ 5572}# (quote (any any)))))
+ #{x\ 5571}#))
+ (module-name (current-module)))))
(define case
- (make-extended-syncase-macro
- (module-ref (current-module) (quote case))
+ (make-syncase-macro
'macro
- (lambda (#{x\ 2728}#)
- ((lambda (#{tmp\ 2729}#)
- ((lambda (#{tmp\ 2730}#)
- (if #{tmp\ 2730}#
- (apply (lambda (#{_\ 2731}#
- #{e\ 2732}#
- #{m1\ 2733}#
- #{m2\ 2734}#)
- ((lambda (#{tmp\ 2735}#)
- ((lambda (#{body\ 2736}#)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage #(body) #((top)) #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(body)
- #((top))
- #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile))
- #{e\ 2732}#))
- #{body\ 2736}#))
- #{tmp\ 2735}#))
- (letrec ((#{f\ 2737}#
- (lambda (#{clause\ 2738}# #{clauses\ 2739}#)
- (if (null? #{clauses\ 2739}#)
- ((lambda (#{tmp\ 2741}#)
- ((lambda (#{tmp\ 2742}#)
- (if #{tmp\ 2742}#
- (apply (lambda (#{e1\ 2743}#
- #{e2\ 2744}#)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (cons #{e1\ 2743}#
- #{e2\ 2744}#)))
- #{tmp\ 2742}#)
- ((lambda (#{tmp\ 2746}#)
- (if #{tmp\ 2746}#
- (apply (lambda (#{k\ 2747}#
- #{e1\ 2748}#
- #{e2\ 2749}#)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
+ (cons (lambda (#{x\ 5576}#)
+ ((lambda (#{tmp\ 5577}#)
+ ((lambda (#{tmp\ 5578}#)
+ (if #{tmp\ 5578}#
+ (apply (lambda (#{_\ 5579}#
+ #{e\ 5580}#
+ #{m1\ 5581}#
+ #{m2\ 5582}#)
+ ((lambda (#{tmp\ 5583}#)
+ ((lambda (#{body\ 5584}#)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage #(body) #((top)) #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(body)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #{e\ 5580}#))
+ #{body\ 5584}#))
+ #{tmp\ 5583}#))
+ (letrec ((#{f\ 5585}#
+ (lambda (#{clause\ 5586}#
+ #{clauses\ 5587}#)
+ (if (null? #{clauses\ 5587}#)
+ ((lambda (#{tmp\ 5589}#)
+ ((lambda (#{tmp\ 5590}#)
+ (if #{tmp\ 5590}#
+ (apply (lambda (#{e1\ 5591}#
+ #{e2\ 5592}#)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (cons #{e1\ 5591}#
+ #{e2\ 5592}#)))
+ #{tmp\ 5590}#)
+ ((lambda (#{tmp\ 5594}#)
+ (if #{tmp\ 5594}#
+ (apply (lambda (#{k\ 5595}#
+ #{e1\ 5596}#
+ #{e2\ 5597}#)
(list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- '#(syntax-object
- t
+ if
((top)
#(ribcage
#(k
(hygiene
guile))
(list '#(syntax-object
- quote
+ memv
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ '#(syntax-object
+ t
((top)
#(ribcage
#(k
#("i")))
(hygiene
guile))
- #{k\ 2747}#))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (cons #{e1\ 2748}#
- #{e2\ 2749}#))))
- #{tmp\ 2746}#)
- ((lambda (#{_\ 2752}#)
- (syntax-violation
- 'case
- "bad clause"
- #{x\ 2728}#
- #{clause\ 2738}#))
- #{tmp\ 2741}#)))
- ($sc-dispatch
- #{tmp\ 2741}#
- '(each-any
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{k\ 5595}#))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (cons #{e1\ 5596}#
+ #{e2\ 5597}#))))
+ #{tmp\ 5594}#)
+ ((lambda (#{_\ 5600}#)
+ (syntax-violation
+ 'case
+ "bad clause"
+ #{x\ 5576}#
+ #{clause\ 5586}#))
+ #{tmp\ 5589}#)))
+ ($sc-dispatch
+ #{tmp\ 5589}#
+ '(each-any
+ any
+ .
+ each-any)))))
+ ($sc-dispatch
+ #{tmp\ 5589}#
+ '(#(free-id
+ #(syntax-object
+ else
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(f clause clauses)
+ #((top)
+ (top)
+ (top))
+ #("i" "i" "i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile)))
any
.
- each-any)))))
- ($sc-dispatch
- #{tmp\ 2741}#
- '(#(free-id
- #(syntax-object
- else
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("i" "i" "i"))
- #(ribcage
- #(_ e m1 m2)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile)))
- any
- .
- each-any))))
- #{clause\ 2738}#)
- ((lambda (#{tmp\ 2753}#)
- ((lambda (#{rest\ 2754}#)
- ((lambda (#{tmp\ 2755}#)
- ((lambda (#{tmp\ 2756}#)
- (if #{tmp\ 2756}#
- (apply (lambda (#{k\ 2757}#
- #{e1\ 2758}#
- #{e2\ 2759}#)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
+ each-any))))
+ #{clause\ 5586}#)
+ ((lambda (#{tmp\ 5601}#)
+ ((lambda (#{rest\ 5602}#)
+ ((lambda (#{tmp\ 5603}#)
+ ((lambda (#{tmp\ 5604}#)
+ (if #{tmp\ 5604}#
+ (apply (lambda (#{k\ 5605}#
+ #{e1\ 5606}#
+ #{e2\ 5607}#)
(list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- '#(syntax-object
- t
+ if
((top)
#(ribcage
#(k
(hygiene
guile))
(list '#(syntax-object
- quote
+ memv
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ '#(syntax-object
+ t
((top)
#(ribcage
#(k
#("i")))
(hygiene
guile))
- #{k\ 2757}#))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (cons #{e1\ 2758}#
- #{e2\ 2759}#))
- #{rest\ 2754}#))
- #{tmp\ 2756}#)
- ((lambda (#{_\ 2762}#)
- (syntax-violation
- 'case
- "bad clause"
- #{x\ 2728}#
- #{clause\ 2738}#))
- #{tmp\ 2755}#)))
- ($sc-dispatch
- #{tmp\ 2755}#
- '(each-any
- any
- .
- each-any))))
- #{clause\ 2738}#))
- #{tmp\ 2753}#))
- (#{f\ 2737}#
- (car #{clauses\ 2739}#)
- (cdr #{clauses\ 2739}#)))))))
- (#{f\ 2737}# #{m1\ 2733}# #{m2\ 2734}#))))
- #{tmp\ 2730}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2729}#)))
- ($sc-dispatch
- #{tmp\ 2729}#
- '(any any any . each-any))))
- #{x\ 2728}#))))
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{k\ 5605}#))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (cons #{e1\ 5606}#
+ #{e2\ 5607}#))
+ #{rest\ 5602}#))
+ #{tmp\ 5604}#)
+ ((lambda (#{_\ 5610}#)
+ (syntax-violation
+ 'case
+ "bad clause"
+ #{x\ 5576}#
+ #{clause\ 5586}#))
+ #{tmp\ 5603}#)))
+ ($sc-dispatch
+ #{tmp\ 5603}#
+ '(each-any
+ any
+ .
+ each-any))))
+ #{clause\ 5586}#))
+ #{tmp\ 5601}#))
+ (#{f\ 5585}#
+ (car #{clauses\ 5587}#)
+ (cdr #{clauses\ 5587}#)))))))
+ (#{f\ 5585}# #{m1\ 5581}# #{m2\ 5582}#))))
+ #{tmp\ 5578}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5577}#)))
+ ($sc-dispatch
+ #{tmp\ 5577}#
+ '(any any any . each-any))))
+ #{x\ 5576}#))
+ (module-name (current-module)))))
(define identifier-syntax
(make-syncase-macro
'macro
- (lambda (#{x\ 2763}#)
- ((lambda (#{tmp\ 2764}#)
- ((lambda (#{tmp\ 2765}#)
- (if #{tmp\ 2765}#
- (apply (lambda (#{_\ 2766}# #{e\ 2767}#)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage #(_ e) #((top) (top)) #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage #(_ e) #((top) (top)) #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile)))
+ (cons (lambda (#{x\ 5611}#)
+ ((lambda (#{tmp\ 5612}#)
+ ((lambda (#{tmp\ 5613}#)
+ (if #{tmp\ 5613}#
+ (apply (lambda (#{_\ 5614}# #{e\ 5615}#)
(list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- '#(syntax-object
- x
+ lambda
((top)
#(ribcage
#(_ e)
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- '()
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile)))
(list '#(syntax-object
- id
+ syntax-case
((top)
#(ribcage
#(_ e)
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- '(#(syntax-object
- identifier?
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- (#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))
- #(syntax-object
- id
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
- (hygiene guile))))
+ '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ '()
(list '#(syntax-object
- syntax
+ id
((top)
#(ribcage
#(_ e)
#((top))
#("i")))
(hygiene guile))
- #{e\ 2767}#))
- (list (cons #{_\ 2766}#
'(#(syntax-object
- x
+ identifier?
((top)
#(ribcage
#(_ e)
#((top))
#("i")))
(hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile))
- (cons #{e\ 2767}#
+ (#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #(syntax-object
+ id
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #{e\ 5615}#))
+ (list (cons #{_\ 5614}#
'(#(syntax-object
x
((top)
#(x)
#((top))
#("i")))
- (hygiene
- guile)))))))))
- #{tmp\ 2765}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 2764}#)))
- ($sc-dispatch #{tmp\ 2764}# (quote (any any)))))
- #{x\ 2763}#))))
+ (hygiene guile))))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons #{e\ 5615}#
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile)))))))))
+ #{tmp\ 5613}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5612}#)))
+ ($sc-dispatch #{tmp\ 5612}# (quote (any any)))))
+ #{x\ 5611}#))
+ (module-name (current-module)))))
+
+(define define*
+ (make-syncase-macro
+ 'macro
+ (cons (lambda (#{x\ 5616}#)
+ ((lambda (#{tmp\ 5617}#)
+ ((lambda (#{tmp\ 5618}#)
+ (if #{tmp\ 5618}#
+ (apply (lambda (#{dummy\ 5619}#
+ #{id\ 5620}#
+ #{args\ 5621}#
+ #{b0\ 5622}#
+ #{b1\ 5623}#)
+ (list '#(syntax-object
+ define
+ ((top)
+ #(ribcage
+ #(dummy id args b0 b1)
+ #(("m" top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #(("m" top)) #("i")))
+ (hygiene guile))
+ #{id\ 5620}#
+ (cons '#(syntax-object
+ lambda*
+ ((top)
+ #(ribcage
+ #(dummy id args b0 b1)
+ #(("m" top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #(("m" top))
+ #("i")))
+ (hygiene guile))
+ (cons #{args\ 5621}#
+ (cons #{b0\ 5622}#
+ #{b1\ 5623}#)))))
+ #{tmp\ 5618}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 5617}#)))
+ ($sc-dispatch
+ #{tmp\ 5617}#
+ '(any (any . any) any . each-any))))
+ #{x\ 5616}#))
+ (module-name (current-module)))))
-;;;; -*-scheme-*-
-;;;;
-;;;; Copyright (C) 2001, 2003, 2006, 2009 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
-;;;;
-\f
-
-;;; Portable implementation of syntax-case
-;;; Extracted from Chez Scheme Version 5.9f
-;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
-
-;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
-;;; revision control logs corresponding to this file: 2009.
-
-;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
-;;; to the ChangeLog distributed in the same directory as this file:
-;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
-;;; 2000-09-12, 2001-03-08
-
-;;; Copyright (c) 1992-1997 Cadence Research Systems
-;;; Permission to copy this software, in whole or in part, to use this
-;;; software for any lawful purpose, and to redistribute this software
-;;; is granted subject to the restriction that all copies made of this
-;;; software must include this copyright notice in full. This software
-;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
-;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
-;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
-;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
-;;; NATURE WHATSOEVER.
-
-;;; Before attempting to port this code to a new implementation of
-;;; Scheme, please read the notes below carefully.
-
-
-;;; This file defines the syntax-case expander, sc-expand, and a set
-;;; of associated syntactic forms and procedures. Of these, the
-;;; following are documented in The Scheme Programming Language,
-;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996). Most are
-;;; also documented in the R4RS and draft R5RS.
-;;;
-;;; bound-identifier=?
-;;; datum->syntax
-;;; define-syntax
-;;; fluid-let-syntax
-;;; free-identifier=?
-;;; generate-temporaries
-;;; identifier?
-;;; identifier-syntax
-;;; let-syntax
-;;; letrec-syntax
-;;; syntax
-;;; syntax-case
-;;; syntax->datum
-;;; syntax-rules
-;;; with-syntax
-;;;
-;;; All standard Scheme syntactic forms are supported by the expander
-;;; or syntactic abstractions defined in this file. Only the R4RS
-;;; delay is omitted, since its expansion is implementation-dependent.
-
-;;; The remaining exports are listed below:
-;;;
-;;; (sc-expand datum)
-;;; if datum represents a valid expression, sc-expand returns an
-;;; expanded version of datum in a core language that includes no
-;;; syntactic abstractions. The core language includes begin,
-;;; define, if, lambda, letrec, quote, and set!.
-;;; (eval-when situations expr ...)
-;;; conditionally evaluates expr ... at compile-time or run-time
-;;; depending upon situations (see the Chez Scheme System Manual,
-;;; Revision 3, for a complete description)
-;;; (syntax-violation who message form [subform])
-;;; used to report errors found during expansion
-;;; ($sc-dispatch e p)
-;;; used by expanded code to handle syntax-case matching
-
-;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors. They are not used by expanded code,
-;;; and so need be present only at expansion time.
-;;;
-;;; (eval x)
-;;; where x is always in the form ("noexpand" expr).
-;;; returns the value of expr. the "noexpand" flag is used to tell the
-;;; evaluator/expander that no expansion is necessary, since expr has
-;;; already been fully expanded to core forms.
-;;;
-;;; eval will not be invoked during the loading of psyntax.pp. After
-;;; psyntax.pp has been loaded, the expansion of any macro definition,
-;;; whether local or global, will result in a call to eval. If, however,
-;;; sc-expand has already been registered as the expander to be used
-;;; by eval, and eval accepts one argument, nothing special must be done
-;;; to support the "noexpand" flag, since it is handled by sc-expand.
-;;;
-;;; (gensym)
-;;; returns a unique symbol each time it's called
-
-;;; When porting to a new Scheme implementation, you should define the
-;;; procedures listed above, load the expanded version of psyntax.ss
-;;; (psyntax.pp, which should be available whereever you found
-;;; psyntax.ss), and register sc-expand as the current expander (how
-;;; you do this depends upon your implementation of Scheme). You may
-;;; change the hooks and constructors defined toward the beginning of
-;;; the code below, but to avoid bootstrapping problems, do so only
-;;; after you have a working version of the expander.
-
-;;; Chez Scheme allows the syntactic form (syntax <template>) to be
-;;; abbreviated to #'<template>, just as (quote <datum>) may be
-;;; abbreviated to '<datum>. The #' syntax makes programs written
-;;; using syntax-case shorter and more readable and draws out the
-;;; intuitive connection between syntax and quote.
-
-;;; If you find that this code loads or runs slowly, consider
-;;; switching to faster hardware or a faster implementation of
-;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
-;;; compiling (with full optimization), and loading this file takes
-;;; between one and two seconds.
-
-;;; In the expander implementation, we sometimes use syntactic abstractions
-;;; when procedural abstractions would suffice. For example, we define
-;;; top-wrap and top-marked? as
-;;; (define-syntax top-wrap (identifier-syntax '((top))))
-;;; (define-syntax top-marked?
-;;; (syntax-rules ()
-;;; ((_ w) (memq 'top (wrap-marks w)))))
-;;; rather than
-;;; (define top-wrap '((top)))
-;;; (define top-marked?
-;;; (lambda (w) (memq 'top (wrap-marks w))))
-;;; On ther other hand, we don't do this consistently; we define make-wrap,
-;;; wrap-marks, and wrap-subst simply as
-;;; (define make-wrap cons)
-;;; (define wrap-marks car)
-;;; (define wrap-subst cdr)
-;;; In Chez Scheme, the syntactic and procedural forms of these
-;;; abstractions are equivalent, since the optimizer consistently
-;;; integrates constants and small procedures. Some Scheme
-;;; implementations, however, may benefit from more consistent use
-;;; of one form or the other.
-
-
-;;; implementation information:
-
-;;; "begin" is treated as a splicing construct at top level and at
-;;; the beginning of bodies. Any sequence of expressions that would
-;;; be allowed where the "begin" occurs is allowed.
-
-;;; "let-syntax" and "letrec-syntax" are also treated as splicing
-;;; constructs, in violation of the R4RS appendix and probably the R5RS
-;;; when it comes out. A consequence, let-syntax and letrec-syntax do
-;;; not create local contours, as do let and letrec. Although the
-;;; functionality is greater as it is presently implemented, we will
-;;; probably change it to conform to the R4RS/expected R5RS.
-
-;;; Objects with no standard print syntax, including objects containing
-;;; cycles and syntax object, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax.
-;;; Such objects are never copied.
-
-;;; All identifiers that don't have macro definitions and are not bound
-;;; lexically are assumed to be global variables
-
-;;; Top-level definitions of macro-introduced identifiers are allowed.
-;;; This may not be appropriate for implementations in which the
-;;; model is that bindings are created by definitions, as opposed to
-;;; one in which initial values are assigned by definitions.
-
-;;; Top-level variable definitions of syntax keywords is not permitted.
-;;; Any solution allowing this would be kludgey and would yield
-;;; surprising results in some cases. We can provide an undefine-syntax
-;;; form. The questions is, should define be an implicit undefine-syntax?
-;;; We've decided no for now.
-
-;;; Identifiers and syntax objects are implemented as vectors for
-;;; portability. As a result, it is possible to "forge" syntax
-;;; objects.
-
-;;; The implementation of generate-temporaries assumes that it is possible
-;;; to generate globally unique symbols (gensyms).
-
-
-;;; Bootstrapping:
-
-;;; When changing syntax-object representations, it is necessary to support
-;;; both old and new syntax-object representations in id-var-name. It
-;;; should be sufficient to recognize old representations and treat
-;;; them as not lexically bound.
-
-
-
-(eval-when (compile)
- (set-current-module (resolve-module '(guile))))
-
-(let ()
-;;; Private version of and-map that handles multiple lists.
-(define and-map*
- (lambda (f first . rest)
- (or (null? first)
- (if (null? rest)
- (let andmap ((first first))
- (let ((x (car first)) (first (cdr first)))
- (if (null? first)
- (f x)
- (and (f x) (andmap first)))))
- (let andmap ((first first) (rest rest))
- (let ((x (car first))
- (xr (map car rest))
- (first (cdr first))
- (rest (map cdr rest)))
- (if (null? first)
- (apply f (cons x xr))
- (and (apply f (cons x xr)) (andmap first rest)))))))))
-
-(define-syntax define-structure
- (lambda (x)
- (define construct-name
- (lambda (template-identifier . args)
- (datum->syntax
- template-identifier
- (string->symbol
- (apply string-append
- (map (lambda (x)
- (if (string? x)
- x
- (symbol->string (syntax->datum x))))
- args))))))
- (syntax-case x ()
- ((_ (name id1 ...))
- (and-map identifier? (syntax (name id1 ...)))
- (with-syntax
- ((constructor (construct-name (syntax name) "make-" (syntax name)))
- (predicate (construct-name (syntax name) (syntax name) "?"))
- ((access ...)
- (map (lambda (x) (construct-name x (syntax name) "-" x))
- (syntax (id1 ...))))
- ((assign ...)
- (map (lambda (x)
- (construct-name x "set-" (syntax name) "-" x "!"))
- (syntax (id1 ...))))
- (structure-length
- (+ (length (syntax (id1 ...))) 1))
- ((index ...)
- (let f ((i 1) (ids (syntax (id1 ...))))
- (if (null? ids)
- '()
- (cons i (f (+ i 1) (cdr ids)))))))
- (syntax (begin
- (define constructor
- (lambda (id1 ...)
- (vector 'name id1 ... )))
- (define predicate
- (lambda (x)
- (and (vector? x)
- (= (vector-length x) structure-length)
- (eq? (vector-ref x 0) 'name))))
- (define access
- (lambda (x)
- (vector-ref x index)))
- ...
- (define assign
- (lambda (x update)
- (vector-set! x index update)))
- ...)))))))
-
-(let ()
-(define noexpand "noexpand")
-(define *mode* (make-fluid))
-
-;;; hooks to nonportable run-time helpers
-(begin
-(define fx+ +)
-(define fx- -)
-(define fx= =)
-(define fx< <)
-
-(define top-level-eval-hook
- (lambda (x mod)
- (primitive-eval
- `(,noexpand
- ,(case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) tree-il->scheme) x))
- (else x))))))
-
-(define local-eval-hook
- (lambda (x mod)
- (primitive-eval
- `(,noexpand
- ,(case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) tree-il->scheme) x))
- (else x))))))
-
-(define-syntax gensym-hook
- (syntax-rules ()
- ((_) (gensym))))
-
-(define put-global-definition-hook
- (lambda (symbol type val)
- (let ((existing (let ((v (module-variable (current-module) symbol)))
- (and v (variable-bound? v)
- (let ((val (variable-ref v)))
- (and (macro? val)
- (not (syncase-macro-type val))
- val))))))
- (module-define! (current-module)
- symbol
- (if existing
- (make-extended-syncase-macro existing type val)
- (make-syncase-macro type val))))))
-
-(define get-global-definition-hook
- (lambda (symbol module)
- (if (and (not module) (current-module))
- (warn "module system is booted, we should have a module" symbol))
- (let ((v (module-variable (if module
- (resolve-module (cdr module))
- (current-module))
- symbol)))
- (and v (variable-bound? v)
- (let ((val (variable-ref v)))
- (and (macro? val) (syncase-macro-type val)
- (cons (syncase-macro-type val)
- (syncase-macro-binding val))))))))
-
-)
-
-
-(define (decorate-source e s)
- (if (and (pair? e) s)
- (set-source-properties! e s))
- e)
-
-;;; output constructors
-(define build-void
- (lambda (source)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-void) source))
- (else (decorate-source '(if #f #f) source)))))
-
-(define build-application
- (lambda (source fun-exp arg-exps)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
- (else (decorate-source `(,fun-exp . ,arg-exps) source)))))
-
-(define build-conditional
- (lambda (source test-exp then-exp else-exp)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-conditional)
- source test-exp then-exp else-exp))
- (else (decorate-source
- (if (equal? else-exp '(if #f #f))
- `(if ,test-exp ,then-exp)
- `(if ,test-exp ,then-exp ,else-exp))
- source)))))
-
-(define build-lexical-reference
- (lambda (type source name var)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lexical-ref) source name var))
- (else (decorate-source var source)))))
-
-(define build-lexical-assignment
- (lambda (source name var exp)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
- (else (decorate-source `(set! ,var ,exp) source)))))
-
-;; Before modules are booted, we can't expand into data structures from
-;; (language tree-il) -- we need to give the evaluator the
-;; s-expressions that it understands natively. Actually the real truth
-;; of the matter is that the evaluator doesn't understand tree-il
-;; structures at all. So until we fix the evaluator, if ever, the
-;; conflation that we should use tree-il iff we are compiling
-;; holds true.
-;;
-(define (analyze-variable mod var modref-cont bare-cont)
- (if (not mod)
- (bare-cont var)
- (let ((kind (car mod))
- (mod (cdr mod)))
- (case kind
- ((public) (modref-cont mod var #t))
- ((private) (if (not (equal? mod (module-name (current-module))))
- (modref-cont mod var #f)
- (bare-cont var)))
- ((bare) (bare-cont var))
- ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
- (module-variable (resolve-module mod) var))
- (modref-cont mod var #f)
- (bare-cont var)))
- (else (syntax-violation #f "bad module kind" var mod))))))
-
-(define build-global-reference
- (lambda (source var mod)
- (analyze-variable
- mod var
- (lambda (mod var public?)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
- (else (decorate-source (list (if public? '@ '@@) mod var) source))))
- (lambda (var)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-toplevel-ref) source var))
- (else (decorate-source var source)))))))
-
-(define build-global-assignment
- (lambda (source var exp mod)
- (analyze-variable
- mod var
- (lambda (mod var public?)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
- (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var) ,exp) source))))
- (lambda (var)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
- (else (decorate-source `(set! ,var ,exp) source)))))))
-
-;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
-;; from working. Hack around it.
-(define (maybe-name-value! name val)
- (cond
- (((@ (language tree-il) lambda?) val)
- (let ((meta ((@ (language tree-il) lambda-meta) val)))
- (if (not (assq 'name meta))
- ((setter (@ (language tree-il) lambda-meta))
- val
- (acons 'name name meta)))))))
-
-(define build-global-definition
- (lambda (source var exp)
- (case (fluid-ref *mode*)
- ((c)
- (maybe-name-value! var exp)
- ((@ (language tree-il) make-toplevel-define) source var exp))
- (else (decorate-source `(define ,var ,exp) source)))))
-
-(define build-lambda
- (lambda (src ids vars docstring exp)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lambda) src ids vars
- (if docstring `((documentation . ,docstring)) '())
- exp))
- (else (decorate-source
- `(lambda ,vars ,@(if docstring (list docstring) '())
- ,exp)
- src)))))
-
-(define build-primref
- (lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-toplevel-ref) src name))
- (else (decorate-source name src)))
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
- (else (decorate-source `(@@ (guile) ,name) src))))))
-
-(define (build-data src exp)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-const) src exp))
- (else (decorate-source
- (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- (list 'quote exp))
- src))))
-
-(define build-sequence
- (lambda (src exps)
- (if (null? (cdr exps))
- (car exps)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-sequence) src exps))
- (else (decorate-source `(begin ,@exps) src))))))
-
-(define build-let
- (lambda (src ids vars val-exps body-exp)
- (if (null? vars)
- body-exp
- (case (fluid-ref *mode*)
- ((c)
- (for-each maybe-name-value! ids val-exps)
- ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
- (else (decorate-source
- `(let ,(map list vars val-exps) ,body-exp)
- src))))))
-
-(define build-named-let
- (lambda (src ids vars val-exps body-exp)
- (let ((f (car vars))
- (f-name (car ids))
- (vars (cdr vars))
- (ids (cdr ids)))
- (case (fluid-ref *mode*)
- ((c)
- (let ((proc (build-lambda src ids vars #f body-exp)))
- (maybe-name-value! f-name proc)
- (for-each maybe-name-value! ids val-exps)
- ((@ (language tree-il) make-letrec) src
- (list f-name) (list f) (list proc)
- (build-application src (build-lexical-reference 'fun src f-name f)
- val-exps))))
- (else (decorate-source
- `(let ,f ,(map list vars val-exps) ,body-exp)
- src))))))
-
-(define build-letrec
- (lambda (src ids vars val-exps body-exp)
- (if (null? vars)
- body-exp
- (case (fluid-ref *mode*)
- ((c)
- (for-each maybe-name-value! ids val-exps)
- ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
- (else (decorate-source
- `(letrec ,(map list vars val-exps) ,body-exp)
- src))))))
-
-;; FIXME: use a faster gensym
-(define-syntax build-lexical-var
- (syntax-rules ()
- ((_ src id) (gensym (string-append (symbol->string id) " ")))))
-
-(define-structure (syntax-object expression wrap module))
-
-(define-syntax no-source (identifier-syntax #f))
-
-(define source-annotation
- (lambda (x)
- (cond
- ((syntax-object? x)
- (source-annotation (syntax-object-expression x)))
- ((pair? x) (let ((props (source-properties x)))
- (if (pair? props)
- props
- #f)))
- (else #f))))
-
-(define-syntax arg-check
- (syntax-rules ()
- ((_ pred? e who)
- (let ((x e))
- (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
-
-;;; compile-time environments
-
-;;; wrap and environment comprise two level mapping.
-;;; wrap : id --> label
-;;; env : label --> <element>
-
-;;; environments are represented in two parts: a lexical part and a global
-;;; part. The lexical part is a simple list of associations from labels
-;;; to bindings. The global part is implemented by
-;;; {put,get}-global-definition-hook and associates symbols with
-;;; bindings.
-
-;;; global (assumed global variable) and displaced-lexical (see below)
-;;; do not show up in any environment; instead, they are fabricated by
-;;; lookup when it finds no other bindings.
-
-;;; <environment> ::= ((<label> . <binding>)*)
-
-;;; identifier bindings include a type and a value
-
-;;; <binding> ::= (macro . <procedure>) macros
-;;; (core . <procedure>) core forms
-;;; (module-ref . <procedure>) @ or @@
-;;; (begin) begin
-;;; (define) define
-;;; (define-syntax) define-syntax
-;;; (local-syntax . rec?) let-syntax/letrec-syntax
-;;; (eval-when) eval-when
-;;; (syntax . (<var> . <level>)) pattern variables
-;;; (global) assumed global variable
-;;; (lexical . <var>) lexical variables
-;;; (displaced-lexical) displaced lexicals
-;;; <level> ::= <nonnegative integer>
-;;; <var> ::= variable returned by build-lexical-var
-
-;;; a macro is a user-defined syntactic-form. a core is a system-defined
-;;; syntactic form. begin, define, define-syntax, and eval-when are
-;;; treated specially since they are sensitive to whether the form is
-;;; at top-level and (except for eval-when) can denote valid internal
-;;; definitions.
-
-;;; a pattern variable is a variable introduced by syntax-case and can
-;;; be referenced only within a syntax form.
-
-;;; any identifier for which no top-level syntax definition or local
-;;; binding of any kind has been seen is assumed to be a global
-;;; variable.
-
-;;; a lexical variable is a lambda- or letrec-bound variable.
-
-;;; a displaced-lexical identifier is a lexical identifier removed from
-;;; it's scope by the return of a syntax object containing the identifier.
-;;; a displaced lexical can also appear when a letrec-syntax-bound
-;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
-;;; a displaced lexical should never occur with properly written macros.
-
-(define-syntax make-binding
- (syntax-rules (quote)
- ((_ type value) (cons type value))
- ((_ 'type) '(type))
- ((_ type) (cons type '()))))
-(define binding-type car)
-(define binding-value cdr)
-
-(define-syntax null-env (identifier-syntax '()))
-
-(define extend-env
- (lambda (labels bindings r)
- (if (null? labels)
- r
- (extend-env (cdr labels) (cdr bindings)
- (cons (cons (car labels) (car bindings)) r)))))
-
-(define extend-var-env
- ; variant of extend-env that forms "lexical" binding
- (lambda (labels vars r)
- (if (null? labels)
- r
- (extend-var-env (cdr labels) (cdr vars)
- (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
-
-;;; we use a "macros only" environment in expansion of local macro
-;;; definitions so that their definitions can use local macros without
-;;; attempting to use other lexical identifiers.
-(define macros-only-env
- (lambda (r)
- (if (null? r)
- '()
- (let ((a (car r)))
- (if (eq? (cadr a) 'macro)
- (cons a (macros-only-env (cdr r)))
- (macros-only-env (cdr r)))))))
-
-(define lookup
- ; x may be a label or a symbol
- ; although symbols are usually global, we check the environment first
- ; anyway because a temporary binding may have been established by
- ; fluid-let-syntax
- (lambda (x r mod)
- (cond
- ((assq x r) => cdr)
- ((symbol? x)
- (or (get-global-definition-hook x mod) (make-binding 'global)))
- (else (make-binding 'displaced-lexical)))))
-
-(define global-extend
- (lambda (type sym val)
- (put-global-definition-hook sym type val)))
-
-
-;;; Conceptually, identifiers are always syntax objects. Internally,
-;;; however, the wrap is sometimes maintained separately (a source of
-;;; efficiency and confusion), so that symbols are also considered
-;;; identifiers by id?. Externally, they are always wrapped.
-
-(define nonsymbol-id?
- (lambda (x)
- (and (syntax-object? x)
- (symbol? (syntax-object-expression x)))))
-
-(define id?
- (lambda (x)
- (cond
- ((symbol? x) #t)
- ((syntax-object? x) (symbol? (syntax-object-expression x)))
- (else #f))))
-
-(define-syntax id-sym-name
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (if (syntax-object? x)
- (syntax-object-expression x)
- x)))))
-
-(define id-sym-name&marks
- (lambda (x w)
- (if (syntax-object? x)
- (values
- (syntax-object-expression x)
- (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
- (values x (wrap-marks w)))))
-
-;;; syntax object wraps
-
-;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
-;;; <subst> ::= <shift> | <subs>
-;;; <subs> ::= #(<old name> <label> (<mark> ...))
-;;; <shift> ::= positive fixnum
-
-(define make-wrap cons)
-(define wrap-marks car)
-(define wrap-subst cdr)
-
-(define-syntax subst-rename? (identifier-syntax vector?))
-(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
-(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
-(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
-(define-syntax make-rename
- (syntax-rules ()
- ((_ old new marks) (vector old new marks))))
-
-;;; labels must be comparable with "eq?" and distinct from symbols.
-(define gen-label
- (lambda () (string #\i)))
-
-(define gen-labels
- (lambda (ls)
- (if (null? ls)
- '()
- (cons (gen-label) (gen-labels (cdr ls))))))
-
-(define-structure (ribcage symnames marks labels))
-
-(define-syntax empty-wrap (identifier-syntax '(())))
-
-(define-syntax top-wrap (identifier-syntax '((top))))
-
-(define-syntax top-marked?
- (syntax-rules ()
- ((_ w) (memq 'top (wrap-marks w)))))
-
-;;; Marks must be comparable with "eq?" and distinct from pairs and
-;;; the symbol top. We do not use integers so that marks will remain
-;;; unique even across file compiles.
-
-(define-syntax the-anti-mark (identifier-syntax #f))
-
-(define anti-mark
- (lambda (w)
- (make-wrap (cons the-anti-mark (wrap-marks w))
- (cons 'shift (wrap-subst w)))))
-
-(define-syntax new-mark
- (syntax-rules ()
- ((_) (string #\m))))
-
-;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
-;;; internal definitions, in which the ribcages are built incrementally
-(define-syntax make-empty-ribcage
- (syntax-rules ()
- ((_) (make-ribcage '() '() '()))))
-
-(define extend-ribcage!
- ; must receive ids with complete wraps
- (lambda (ribcage id label)
- (set-ribcage-symnames! ribcage
- (cons (syntax-object-expression id)
- (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (wrap-marks (syntax-object-wrap id))
- (ribcage-marks ribcage)))
- (set-ribcage-labels! ribcage
- (cons label (ribcage-labels ribcage)))))
-
-;;; make-binding-wrap creates vector-based ribcages
-(define make-binding-wrap
- (lambda (ids labels w)
- (if (null? ids)
- w
- (make-wrap
- (wrap-marks w)
- (cons
- (let ((labelvec (list->vector labels)))
- (let ((n (vector-length labelvec)))
- (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
- (let f ((ids ids) (i 0))
- (if (not (null? ids))
- (call-with-values
- (lambda () (id-sym-name&marks (car ids) w))
- (lambda (symname marks)
- (vector-set! symnamevec i symname)
- (vector-set! marksvec i marks)
- (f (cdr ids) (fx+ i 1))))))
- (make-ribcage symnamevec marksvec labelvec))))
- (wrap-subst w))))))
-
-(define smart-append
- (lambda (m1 m2)
- (if (null? m2)
- m1
- (append m1 m2))))
-
-(define join-wraps
- (lambda (w1 w2)
- (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
- (if (null? m1)
- (if (null? s1)
- w2
- (make-wrap
- (wrap-marks w2)
- (smart-append s1 (wrap-subst w2))))
- (make-wrap
- (smart-append m1 (wrap-marks w2))
- (smart-append s1 (wrap-subst w2)))))))
-
-(define join-marks
- (lambda (m1 m2)
- (smart-append m1 m2)))
-
-(define same-marks?
- (lambda (x y)
- (or (eq? x y)
- (and (not (null? x))
- (not (null? y))
- (eq? (car x) (car y))
- (same-marks? (cdr x) (cdr y))))))
-
-(define id-var-name
- (lambda (id w)
- (define-syntax first
- (syntax-rules ()
- ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
- (define search
- (lambda (sym subst marks)
- (if (null? subst)
- (values #f marks)
- (let ((fst (car subst)))
- (if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
- (let ((symnames (ribcage-symnames fst)))
- (if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
- (define search-list-rib
- (lambda (sym subst marks symnames ribcage)
- (let f ((symnames symnames) (i 0))
- (cond
- ((null? symnames) (search sym (cdr subst) marks))
- ((and (eq? (car symnames) sym)
- (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
- (else (f (cdr symnames) (fx+ i 1)))))))
- (define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
- (let ((n (vector-length symnames)))
- (let f ((i 0))
- (cond
- ((fx= i n) (search sym (cdr subst) marks))
- ((and (eq? (vector-ref symnames i) sym)
- (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
- (else (f (fx+ i 1))))))))
- (cond
- ((symbol? id)
- (or (first (search id (wrap-subst w) (wrap-marks w))) id))
- ((syntax-object? id)
- (let ((id (syntax-object-expression id))
- (w1 (syntax-object-wrap id)))
- (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
- (call-with-values (lambda () (search id (wrap-subst w) marks))
- (lambda (new-id marks)
- (or new-id
- (first (search id (wrap-subst w1) marks))
- id))))))
- (else (syntax-violation 'id-var-name "invalid id" id)))))
-
-;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
-;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
-
-(define free-id=?
- (lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
-;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
-;;; long as the missing portion of the wrap is common to both of the ids
-;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
-
-(define bound-id=?
- (lambda (i j)
- (if (and (syntax-object? i) (syntax-object? j))
- (and (eq? (syntax-object-expression i)
- (syntax-object-expression j))
- (same-marks? (wrap-marks (syntax-object-wrap i))
- (wrap-marks (syntax-object-wrap j))))
- (eq? i j))))
-
-;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
-;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
-;;; as long as the missing portion of the wrap is common to all of the
-;;; ids.
-
-(define valid-bound-ids?
- (lambda (ids)
- (and (let all-ids? ((ids ids))
- (or (null? ids)
- (and (id? (car ids))
- (all-ids? (cdr ids)))))
- (distinct-bound-ids? ids))))
-
-;;; distinct-bound-ids? expects a list of ids and returns #t if there are
-;;; no duplicates. It is quadratic on the length of the id list; long
-;;; lists could be sorted to make it more efficient. distinct-bound-ids?
-;;; may be passed unwrapped (or partially wrapped) ids as long as the
-;;; missing portion of the wrap is common to all of the ids.
-
-(define distinct-bound-ids?
- (lambda (ids)
- (let distinct? ((ids ids))
- (or (null? ids)
- (and (not (bound-id-member? (car ids) (cdr ids)))
- (distinct? (cdr ids)))))))
-
-(define bound-id-member?
- (lambda (x list)
- (and (not (null? list))
- (or (bound-id=? x (car list))
- (bound-id-member? x (cdr list))))))
-
-;;; wrapping expressions and identifiers
-
-(define wrap
- (lambda (x w defmod)
- (cond
- ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
- ((syntax-object? x)
- (make-syntax-object
- (syntax-object-expression x)
- (join-wraps w (syntax-object-wrap x))
- (syntax-object-module x)))
- ((null? x) x)
- (else (make-syntax-object x w defmod)))))
-
-(define source-wrap
- (lambda (x w s defmod)
- (wrap (decorate-source x s) w defmod)))
-
-;;; expanding
-
-(define chi-sequence
- (lambda (body r w s mod)
- (build-sequence s
- (let dobody ((body body) (r r) (w w) (mod mod))
- (if (null? body)
- '()
- (let ((first (chi (car body) r w mod)))
- (cons first (dobody (cdr body) r w mod))))))))
-
-(define chi-top-sequence
- (lambda (body r w s m esew mod)
- (build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
- (if (null? body)
- '()
- (let ((first (chi-top (car body) r w m esew mod)))
- (cons first (dobody (cdr body) r w m esew mod))))))))
-
-(define chi-install-global
- (lambda (name e)
- (build-global-definition
- no-source
- name
- ;; FIXME: seems nasty to call current-module here
- (if (let ((v (module-variable (current-module) name)))
- ;; FIXME use primitive-macro?
- (and v (variable-bound? v) (macro? (variable-ref v))
- (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
- (build-application
- no-source
- (build-primref no-source 'make-extended-syncase-macro)
- (list (build-application
- no-source
- (build-primref no-source 'module-ref)
- (list (build-application
- no-source
- (build-primref no-source 'current-module)
- '())
- (build-data no-source name)))
- (build-data no-source 'macro)
- e))
- (build-application
- no-source
- (build-primref no-source 'make-syncase-macro)
- (list (build-data no-source 'macro) e))))))
-
-(define chi-when-list
- (lambda (e when-list w)
- ; when-list is syntax'd version of list of situations
- (let f ((when-list when-list) (situations '()))
- (if (null? when-list)
- situations
- (f (cdr when-list)
- (cons (let ((x (car when-list)))
- (cond
- ((free-id=? x (syntax compile)) 'compile)
- ((free-id=? x (syntax load)) 'load)
- ((free-id=? x (syntax eval)) 'eval)
- (else (syntax-violation 'eval-when
- "invalid situation"
- e (wrap x w #f)))))
- situations))))))
-
-;;; syntax-type returns six values: type, value, e, w, s, and mod. The
-;;; first two are described in the table below.
-;;;
-;;; type value explanation
-;;; -------------------------------------------------------------------
-;;; core procedure core singleton
-;;; core-form procedure core form
-;;; module-ref procedure @ or @@ singleton
-;;; lexical name lexical variable reference
-;;; global name global variable reference
-;;; begin none begin keyword
-;;; define none define keyword
-;;; define-syntax none define-syntax keyword
-;;; local-syntax rec? letrec-syntax/let-syntax keyword
-;;; eval-when none eval-when keyword
-;;; syntax level pattern variable
-;;; displaced-lexical none displaced lexical identifier
-;;; lexical-call name call to lexical variable
-;;; global-call name call to global variable
-;;; call none any other call
-;;; begin-form none begin expression
-;;; define-form id variable definition
-;;; define-syntax-form id syntax definition
-;;; local-syntax-form rec? syntax definition
-;;; eval-when-form none eval-when form
-;;; constant none self-evaluating datum
-;;; other none anything else
-;;;
-;;; For define-form and define-syntax-form, e is the rhs expression.
-;;; For all others, e is the entire form. w is the wrap for e.
-;;; s is the source for the entire form. mod is the module for e.
-;;;
-;;; syntax-type expands macros and unwraps as necessary to get to
-;;; one of the forms above. It also parses define and define-syntax
-;;; forms, although perhaps this should be done by the consumer.
-
-(define syntax-type
- (lambda (e r w s rib mod for-car?)
- (cond
- ((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r mod))
- (type (binding-type b)))
- (case type
- ((lexical) (values type (binding-value b) e w s mod))
- ((global) (values type n e w s mod))
- ((macro)
- (if for-car?
- (values type (binding-value b) e w s mod)
- (syntax-type (chi-macro (binding-value b) e r w rib mod)
- r empty-wrap s rib mod #f)))
- (else (values type (binding-value b) e w s mod)))))
- ((pair? e)
- (let ((first (car e)))
- (call-with-values
- (lambda () (syntax-type first r w s rib mod #t))
- (lambda (ftype fval fe fw fs fmod)
- (case ftype
- ((lexical)
- (values 'lexical-call fval e w s mod))
- ((global)
- ;; If we got here via an (@@ ...) expansion, we need to
- ;; make sure the fmod information is propagated back
- ;; correctly -- hence this consing.
- (values 'global-call (make-syntax-object fval w fmod)
- e w s mod))
- ((macro)
- (syntax-type (chi-macro fval e r w rib mod)
- r empty-wrap s rib mod for-car?))
- ((module-ref)
- (call-with-values (lambda () (fval e))
- (lambda (sym mod)
- (syntax-type sym r w s rib mod for-car?))))
- ((core)
- (values 'core-form fval e w s mod))
- ((local-syntax)
- (values 'local-syntax-form fval e w s mod))
- ((begin)
- (values 'begin-form #f e w s mod))
- ((eval-when)
- (values 'eval-when-form #f e w s mod))
- ((define)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (values 'define-form (syntax name) (syntax val) w s mod))
- ((_ (name . args) e1 e2 ...)
- (and (id? (syntax name))
- (valid-bound-ids? (lambda-var-list (syntax args))))
- ; need lambda here...
- (values 'define-form (wrap (syntax name) w mod)
- (decorate-source
- (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod))
- s)
- empty-wrap s mod))
- ((_ name)
- (id? (syntax name))
- (values 'define-form (wrap (syntax name) w mod)
- (syntax (if #f #f))
- empty-wrap s mod))))
- ((define-syntax)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (values 'define-syntax-form (syntax name)
- (syntax val) w s mod))))
- (else
- (values 'call #f e w s mod)))))))
- ((syntax-object? e)
- (syntax-type (syntax-object-expression e)
- r
- (join-wraps w (syntax-object-wrap e))
- s rib (or (syntax-object-module e) mod) for-car?))
- ((self-evaluating? e) (values 'constant #f e w s mod))
- (else (values 'other #f e w s mod)))))
-
-(define chi-top
- (lambda (e r w m esew mod)
- (define-syntax eval-if-c&e
- (syntax-rules ()
- ((_ m e mod)
- (let ((x e))
- (if (eq? m 'c&e) (top-level-eval-hook x mod))
- x))))
- (call-with-values
- (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
- (lambda (type value e w s mod)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) (chi-void))
- ((_ e1 e2 ...)
- (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s mod
- (lambda (body r w s mod)
- (chi-top-sequence body r w s m esew mod))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e (syntax (x ...)) w))
- (body (syntax (e1 e2 ...))))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (chi-top-sequence body r w s 'e '(eval) mod)
- (chi-void)))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (chi-top-sequence body r w s 'c&e '(compile load) mod)
- (if (memq m '(c c&e))
- (chi-top-sequence body r w s 'c '(load) mod)
- (chi-void))))
- ((or (memq 'compile when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (chi-top-sequence body r w s 'e '(eval) mod)
- mod)
- (chi-void))
- (else (chi-void)))))))
- ((define-syntax-form)
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (case m
- ((c)
- (if (memq 'compile esew)
- (let ((e (chi-install-global n (chi e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew) e (chi-void)))
- (if (memq 'load esew)
- (chi-install-global n (chi e r w mod))
- (chi-void))))
- ((c&e)
- (let ((e (chi-install-global n (chi e r w mod))))
- (top-level-eval-hook e mod)
- e))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (chi-install-global n (chi e r w mod))
- mod))
- (chi-void)))))
- ((define-form)
- (let* ((n (id-var-name value w))
- (type (binding-type (lookup n r mod))))
- (case type
- ((global core macro module-ref)
- ;; affect compile-time environment (once we have booted)
- (if (and (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- ;; use value of the same-named imported variable, if
- ;; any
- (module-define! (current-module) n
- (if (variable? old)
- (variable-ref old)
- #f))))
- (eval-if-c&e m
- (build-global-definition s n (chi e r w mod))
- mod))
- ((displaced-lexical)
- (syntax-violation #f "identifier out of context"
- e (wrap value w mod)))
- (else
- (syntax-violation #f "cannot define keyword at top level"
- e (wrap value w mod))))))
- (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
-
-(define chi
- (lambda (e r w mod)
- (call-with-values
- (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
- (lambda (type value e w s mod)
- (chi-expr type value e r w s mod)))))
-
-(define chi-expr
- (lambda (type value e r w s mod)
- (case type
- ((lexical)
- (build-lexical-reference 'value s e value))
- ((core core-form)
- ;; apply transformer
- (value e r w s mod))
- ((module-ref)
- (call-with-values (lambda () (value e))
- ;; we could add a public? arg here
- (lambda (id mod) (build-global-reference s id mod))))
- ((lexical-call)
- (chi-application
- (build-lexical-reference 'fun (source-annotation (car e))
- (car e) value)
- e r w s mod))
- ((global-call)
- (chi-application
- (build-global-reference (source-annotation (car e))
- (if (syntax-object? value)
- (syntax-object-expression value)
- value)
- (if (syntax-object? value)
- (syntax-object-module value)
- mod))
- e r w s mod))
- ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
- ((global) (build-global-reference s value mod))
- ((call) (chi-application (chi (car e) r w mod) e r w s mod))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s mod chi-sequence))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e (syntax (x ...)) w)))
- (if (memq 'eval when-list)
- (chi-sequence (syntax (e1 e2 ...)) r w s mod)
- (chi-void))))))
- ((define-form define-syntax-form)
- (syntax-violation #f "definition in expression context"
- e (wrap value w mod)))
- ((syntax)
- (syntax-violation #f "reference to pattern variable outside syntax form"
- (source-wrap e w s mod)))
- ((displaced-lexical)
- (syntax-violation #f "reference to identifier outside its scope"
- (source-wrap e w s mod)))
- (else (syntax-violation #f "unexpected syntax"
- (source-wrap e w s mod))))))
-
-(define chi-application
- (lambda (x e r w s mod)
- (syntax-case e ()
- ((e0 e1 ...)
- (build-application s x
- (map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
-
-(define chi-macro
- (lambda (p e r w rib mod)
- (define rebuild-macro-output
- (lambda (x m)
- (cond ((pair? x)
- (cons (rebuild-macro-output (car x) m)
- (rebuild-macro-output (cdr x) m)))
- ((syntax-object? x)
- (let ((w (syntax-object-wrap x)))
- (let ((ms (wrap-marks w)) (s (wrap-subst w)))
- (if (and (pair? ms) (eq? (car ms) the-anti-mark))
- ;; output is from original text
- (make-syntax-object
- (syntax-object-expression x)
- (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
- (syntax-object-module x))
- ;; output introduced by macro
- (make-syntax-object
- (syntax-object-expression x)
- (make-wrap (cons m ms)
- (if rib
- (cons rib (cons 'shift s))
- (cons 'shift s)))
- (let ((pmod (procedure-module p)))
- (if pmod
- ;; hither the hygiene
- (cons 'hygiene (module-name pmod))
- ;; but it's possible for the proc to have
- ;; no mod, if it was made before modules
- ;; were booted
- '(hygiene guile))))))))
- ((vector? x)
- (let* ((n (vector-length x)) (v (make-vector n)))
- (do ((i 0 (fx+ i 1)))
- ((fx= i n) v)
- (vector-set! v i
- (rebuild-macro-output (vector-ref x i) m)))))
- ((symbol? x)
- (syntax-violation #f "encountered raw symbol in macro output"
- (source-wrap e w s mod) x))
- (else x))))
- (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
-
-(define chi-body
- ;; In processing the forms of the body, we create a new, empty wrap.
- ;; This wrap is augmented (destructively) each time we discover that
- ;; the next form is a definition. This is done:
- ;;
- ;; (1) to allow the first nondefinition form to be a call to
- ;; one of the defined ids even if the id previously denoted a
- ;; definition keyword or keyword for a macro expanding into a
- ;; definition;
- ;; (2) to prevent subsequent definition forms (but unfortunately
- ;; not earlier ones) and the first nondefinition form from
- ;; confusing one of the bound identifiers for an auxiliary
- ;; keyword; and
- ;; (3) so that we do not need to restart the expansion of the
- ;; first nondefinition form, which is problematic anyway
- ;; since it might be the first element of a begin that we
- ;; have just spliced into the body (meaning if we restarted,
- ;; we'd really need to restart with the begin or the macro
- ;; call that expanded into the begin, and we'd have to give
- ;; up allowing (begin <defn>+ <expr>+), which is itself
- ;; problematic since we don't know if a begin contains only
- ;; definitions until we've expanded it).
- ;;
- ;; Before processing the body, we also create a new environment
- ;; containing a placeholder for the bindings we will add later and
- ;; associate this environment with each form. In processing a
- ;; let-syntax or letrec-syntax, the associated environment may be
- ;; augmented with local keyword bindings, so the environment may
- ;; be different for different forms in the body. Once we have
- ;; gathered up all of the definitions, we evaluate the transformer
- ;; expressions and splice into r at the placeholder the new variable
- ;; and keyword bindings. This allows let-syntax or letrec-syntax
- ;; forms local to a portion or all of the body to shadow the
- ;; definition bindings.
- ;;
- ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
- ;; into the body.
- ;;
- ;; outer-form is fully wrapped w/source
- (lambda (body outer-form r w mod)
- (let* ((r (cons '("placeholder" . (placeholder)) r))
- (ribcage (make-empty-ribcage))
- (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
- (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
- (ids '()) (labels '())
- (var-ids '()) (vars '()) (vals '()) (bindings '()))
- (if (null? body)
- (syntax-violation #f "no expressions in body" outer-form)
- (let ((e (cdar body)) (er (caar body)))
- (call-with-values
- (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
- (lambda (type value e w s mod)
- (case type
- ((define-form)
- (let ((id (wrap value w mod)) (label (gen-label)))
- (let ((var (gen-var id)))
- (extend-ribcage! ribcage id label)
- (parse (cdr body)
- (cons id ids) (cons label labels)
- (cons id var-ids)
- (cons var vars) (cons (cons er (wrap e w mod)) vals)
- (cons (make-binding 'lexical var) bindings)))))
- ((define-syntax-form)
- (let ((id (wrap value w mod)) (label (gen-label)))
- (extend-ribcage! ribcage id label)
- (parse (cdr body)
- (cons id ids) (cons label labels)
- var-ids vars vals
- (cons (make-binding 'macro (cons er (wrap e w mod)))
- bindings))))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 ...)
- (parse (let f ((forms (syntax (e1 ...))))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w mod))
- (f (cdr forms)))))
- ids labels var-ids vars vals bindings))))
- ((local-syntax-form)
- (chi-local-syntax value e er w s mod
- (lambda (forms er w s mod)
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w mod))
- (f (cdr forms)))))
- ids labels var-ids vars vals bindings))))
- (else ; found a non-definition
- (if (null? ids)
- (build-sequence no-source
- (map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
- (cons (cons er (source-wrap e w s mod))
- (cdr body))))
- (begin
- (if (not (valid-bound-ids? ids))
- (syntax-violation
- #f "invalid or duplicate identifier in definition"
- outer-form))
- (let loop ((bs bindings) (er-cache #f) (r-cache #f))
- (if (not (null? bs))
- (let* ((b (car bs)))
- (if (eq? (car b) 'macro)
- (let* ((er (cadr b))
- (r-cache
- (if (eq? er er-cache)
- r-cache
- (macros-only-env er))))
- (set-cdr! b
- (eval-local-transformer
- (chi (cddr b) r-cache empty-wrap mod)
- mod))
- (loop (cdr bs) er r-cache))
- (loop (cdr bs) er-cache r-cache)))))
- (set-cdr! r (extend-env labels bindings (cdr r)))
- (build-letrec no-source
- (map syntax->datum var-ids)
- vars
- (map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
- vals)
- (build-sequence no-source
- (map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
- (cons (cons er (source-wrap e w s mod))
- (cdr body)))))))))))))))))
-
-(define chi-lambda-clause
- (lambda (e docstring c r w mod k)
- (syntax-case c ()
- ((args doc e1 e2 ...)
- (and (string? (syntax->datum (syntax doc))) (not docstring))
- (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
- (((id ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'lambda "invalid parameter list" e)
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (k (map syntax->datum ids)
- new-vars
- (and docstring (syntax->datum docstring))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env labels new-vars r)
- (make-binding-wrap ids labels w)
- mod))))))
- ((ids e1 e2 ...)
- (let ((old-ids (lambda-var-list (syntax ids))))
- (if (not (valid-bound-ids? old-ids))
- (syntax-violation 'lambda "invalid parameter list" e)
- (let ((labels (gen-labels old-ids))
- (new-vars (map gen-var old-ids)))
- (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids)))
- (if (null? ls1)
- (syntax->datum ls2)
- (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2))))
- (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
- (if (null? ls1)
- ls2
- (f (cdr ls1) (cons (car ls1) ls2))))
- (and docstring (syntax->datum docstring))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env labels new-vars r)
- (make-binding-wrap old-ids labels w)
- mod))))))
- (_ (syntax-violation 'lambda "bad lambda" e)))))
-
-(define chi-local-syntax
- (lambda (rec? e r w s mod k)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-violation #f "duplicate bound keyword" e)
- (let ((labels (gen-labels ids)))
- (let ((new-w (make-binding-wrap ids labels w)))
- (k (syntax (e1 e2 ...))
- (extend-env
- labels
- (let ((w (if rec? new-w w))
- (trans-r (macros-only-env r)))
- (map (lambda (x)
- (make-binding 'macro
- (eval-local-transformer
- (chi x trans-r w mod)
- mod)))
- (syntax (val ...))))
- r)
- new-w
- s
- mod))))))
- (_ (syntax-violation #f "bad local syntax definition"
- (source-wrap e w s mod))))))
-
-(define eval-local-transformer
- (lambda (expanded mod)
- (let ((p (local-eval-hook expanded mod)))
- (if (procedure? p)
- p
- (syntax-violation #f "nonprocedure transformer" p)))))
-
-(define chi-void
- (lambda ()
- (build-void no-source)))
-
-(define ellipsis?
- (lambda (x)
- (and (nonsymbol-id? x)
- (free-id=? x (syntax (... ...))))))
-
-;;; data
-
-;;; strips syntax-objects down to top-wrap
-;;;
-;;; since only the head of a list is annotated by the reader, not each pair
-;;; in the spine, we also check for pairs whose cars are annotated in case
-;;; we've been passed the cdr of an annotated list
-
-(define strip
- (lambda (x w)
- (if (top-marked? w)
- x
- (let f ((x x))
- (cond
- ((syntax-object? x)
- (strip (syntax-object-expression x) (syntax-object-wrap x)))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x)))
- x
- (cons a d))))
- ((vector? x)
- (let ((old (vector->list x)))
- (let ((new (map f old)))
- (if (and-map* eq? old new) x (list->vector new)))))
- (else x))))))
-
-;;; lexical variables
-
-(define gen-var
- (lambda (id)
- (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
- (build-lexical-var no-source id))))
-
-(define lambda-var-list
- (lambda (vars)
- (let lvl ((vars vars) (ls '()) (w empty-wrap))
- (cond
- ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
- ((id? vars) (cons (wrap vars w #f) ls))
- ((null? vars) ls)
- ((syntax-object? vars)
- (lvl (syntax-object-expression vars)
- ls
- (join-wraps w (syntax-object-wrap vars))))
- ; include anything else to be caught by subsequent error
- ; checking
- (else (cons vars ls))))))
-
-;;; core transformers
-
-(global-extend 'local-syntax 'letrec-syntax #t)
-(global-extend 'local-syntax 'let-syntax #f)
-
-(global-extend 'core 'fluid-let-syntax
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? (syntax (var ...)))
- (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
- (for-each
- (lambda (id n)
- (case (binding-type (lookup n r mod))
- ((displaced-lexical)
- (syntax-violation 'fluid-let-syntax
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- (syntax (var ...))
- names)
- (chi-body
- (syntax (e1 e2 ...))
- (source-wrap e w s mod)
- (extend-env
- names
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (make-binding 'macro
- (eval-local-transformer (chi x trans-r w mod)
- mod)))
- (syntax (val ...))))
- r)
- w
- mod)))
- (_ (syntax-violation 'fluid-let-syntax "bad syntax"
- (source-wrap e w s mod))))))
-
-(global-extend 'core 'quote
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ e) (build-data s (strip (syntax e) w)))
- (_ (syntax-violation 'quote "bad syntax"
- (source-wrap e w s mod))))))
-
-(global-extend 'core 'syntax
- (let ()
- (define gen-syntax
- (lambda (src e r maps ellipsis? mod)
- (if (id? e)
- (let ((label (id-var-name e empty-wrap)))
- (let ((b (lookup label r mod)))
- (if (eq? (binding-type b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (binding-value b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values `(ref ,var) maps)))
- (if (ellipsis? e)
- (syntax-violation 'syntax "misplaced ellipsis" src)
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? (syntax dots))
- (gen-syntax src (syntax e) r maps (lambda (x) #f) mod))
- ((x dots . y)
- ; this could be about a dozen lines of code, except that we
- ; choose to handle (syntax (x ... ...)) forms
- (ellipsis? (syntax dots))
- (let f ((y (syntax y))
- (k (lambda (maps)
- (call-with-values
- (lambda ()
- (gen-syntax src (syntax x) r
- (cons '() maps) ellipsis? mod))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis"
- src)
- (values (gen-map x (car maps))
- (cdr maps))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? (syntax dots))
- (f (syntax y)
- (lambda (maps)
- (call-with-values
- (lambda () (k (cons '() maps)))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis" src)
- (values (gen-mappend x (car maps))
- (cdr maps))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis? mod))
- (lambda (y maps)
- (call-with-values
- (lambda () (k maps))
- (lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((x . y)
- (call-with-values
- (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod))
- (lambda (y maps) (values (gen-cons x y) maps))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod))
- (lambda (e maps) (values (gen-vector e) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-violation 'syntax "missing ellipsis" src)
- (call-with-values
- (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
- (lambda (outer-var outer-maps)
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps)))))))))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ; identity map equivalence:
- ; (map (lambda (x) x) y) == y
- (car actuals))
- ((and-map
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ; eta map equivalence:
- ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- (define gen-cons
- (lambda (x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y)))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-vector
- (lambda (x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x))))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ x)
- (call-with-values
- (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
- (lambda (e maps) (regen e))))
- (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
-
-
-(global-extend 'core 'lambda
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ . c)
- (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
- (lambda (names vars docstring body)
- (build-lambda s names vars docstring body)))))))
-
-
-(global-extend 'core 'let
- (let ()
- (define (chi-let e r w s mod constructor ids vals exps)
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'let "duplicate bound variable" e)
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (let ((nw (make-binding-wrap ids labels w))
- (nr (extend-var-env labels new-vars r)))
- (constructor s
- (map syntax->datum ids)
- new-vars
- (map (lambda (x) (chi x r w mod)) vals)
- (chi-body exps (source-wrap e nw s mod)
- nr nw mod))))))
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (and-map id? (syntax (id ...)))
- (chi-let e r w s mod
- build-let
- (syntax (id ...))
- (syntax (val ...))
- (syntax (e1 e2 ...))))
- ((_ f ((id val) ...) e1 e2 ...)
- (and (id? (syntax f)) (and-map id? (syntax (id ...))))
- (chi-let e r w s mod
- build-named-let
- (syntax (f id ...))
- (syntax (val ...))
- (syntax (e1 e2 ...))))
- (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
-
-
-(global-extend 'core 'letrec
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (and-map id? (syntax (id ...)))
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'letrec "duplicate bound variable" e)
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (let ((w (make-binding-wrap ids labels w))
- (r (extend-var-env labels new-vars r)))
- (build-letrec s
- (map syntax->datum ids)
- new-vars
- (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
- (chi-body (syntax (e1 e2 ...))
- (source-wrap e w s mod) r w mod)))))))
- (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
-
-
-(global-extend 'core 'set!
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ id val)
- (id? (syntax id))
- (let ((val (chi (syntax val) r w mod))
- (n (id-var-name (syntax id) w)))
- (let ((b (lookup n r mod)))
- (case (binding-type b)
- ((lexical)
- (build-lexical-assignment s
- (syntax->datum (syntax id))
- (binding-value b)
- val))
- ((global) (build-global-assignment s n val mod))
- ((displaced-lexical)
- (syntax-violation 'set! "identifier out of context"
- (wrap (syntax id) w mod)))
- (else (syntax-violation 'set! "bad set!"
- (source-wrap e w s mod)))))))
- ((_ (head tail ...) val)
- (call-with-values
- (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod #t))
- (lambda (type value ee ww ss modmod)
- (case type
- ((module-ref)
- (let ((val (chi (syntax val) r w mod)))
- (call-with-values (lambda () (value (syntax (head tail ...))))
- (lambda (id mod)
- (build-global-assignment s id val mod)))))
- (else
- (build-application s
- (chi (syntax (setter head)) r w mod)
- (map (lambda (e) (chi e r w mod))
- (syntax (tail ... val)))))))))
- (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
-
-(global-extend 'module-ref '@
- (lambda (e)
- (syntax-case e ()
- ((_ (mod ...) id)
- (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
- (values (syntax->datum (syntax id))
- (syntax->datum
- (syntax (public mod ...))))))))
-
-(global-extend 'module-ref '@@
- (lambda (e)
- (syntax-case e ()
- ((_ (mod ...) id)
- (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
- (values (syntax->datum (syntax id))
- (syntax->datum
- (syntax (private mod ...))))))))
-
-(global-extend 'core 'if
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ test then)
- (build-conditional
- s
- (chi (syntax test) r w mod)
- (chi (syntax then) r w mod)
- (build-void no-source)))
- ((_ test then else)
- (build-conditional
- s
- (chi (syntax test) r w mod)
- (chi (syntax then) r w mod)
- (chi (syntax else) r w mod))))))
-
-(global-extend 'begin 'begin '())
-
-(global-extend 'define 'define '())
-
-(global-extend 'define-syntax 'define-syntax '())
-
-(global-extend 'eval-when 'eval-when '())
-
-(global-extend 'core 'syntax-case
- (let ()
- (define convert-pattern
- ; accepts pattern & keys
- ; returns $sc-dispatch pattern & ids
- (lambda (pattern keys)
- (let cvt ((p pattern) (n 0) (ids '()))
- (if (id? p)
- (if (bound-id-member? p keys)
- (values (vector 'free-id p) ids)
- (values 'any (cons (cons p n) ids)))
- (syntax-case p ()
- ((x dots)
- (ellipsis? (syntax dots))
- (call-with-values
- (lambda () (cvt (syntax x) (fx+ n 1) ids))
- (lambda (p ids)
- (values (if (eq? p 'any) 'each-any (vector 'each p))
- ids))))
- ((x . y)
- (call-with-values
- (lambda () (cvt (syntax y) n ids))
- (lambda (y ids)
- (call-with-values
- (lambda () (cvt (syntax x) n ids))
- (lambda (x ids)
- (values (cons x y) ids))))))
- (() (values '() ids))
- (#(x ...)
- (call-with-values
- (lambda () (cvt (syntax (x ...)) n ids))
- (lambda (p ids) (values (vector 'vector p) ids))))
- (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
-
- (define build-dispatch-call
- (lambda (pvars exp y r mod)
- (let ((ids (map car pvars)) (levels (map cdr pvars)))
- (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application no-source
- (build-primref no-source 'apply)
- (list (build-lambda no-source (map syntax->datum ids) new-vars #f
- (chi exp
- (extend-env
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)
- mod))
- y))))))
-
- (define gen-clause
- (lambda (x keys clauses r pat fender exp mod)
- (call-with-values
- (lambda () (convert-pattern pat keys))
- (lambda (p pvars)
- (cond
- ((not (distinct-bound-ids? (map car pvars)))
- (syntax-violation 'syntax-case "duplicate pattern variable" pat))
- ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-violation 'syntax-case "misplaced ellipsis" pat))
- (else
- (let ((y (gen-var 'tmp)))
- ; fat finger binding and references to temp variable y
- (build-application no-source
- (build-lambda no-source (list 'tmp) (list y) #f
- (let ((y (build-lexical-reference 'value no-source
- 'tmp y)))
- (build-conditional no-source
- (syntax-case fender ()
- (#t y)
- (_ (build-conditional no-source
- y
- (build-dispatch-call pvars fender y r mod)
- (build-data no-source #f))))
- (build-dispatch-call pvars exp y r mod)
- (gen-syntax-case x keys clauses r mod))))
- (list (if (eq? p 'any)
- (build-application no-source
- (build-primref no-source 'list)
- (list x))
- (build-application no-source
- (build-primref no-source '$sc-dispatch)
- (list x (build-data no-source p)))))))))))))
-
- (define gen-syntax-case
- (lambda (x keys clauses r mod)
- (if (null? clauses)
- (build-application no-source
- (build-primref no-source 'syntax-violation)
- (list (build-data no-source #f)
- (build-data no-source
- "source expression failed to match any pattern")
- x))
- (syntax-case (car clauses) ()
- ((pat exp)
- (if (and (id? (syntax pat))
- (and-map (lambda (x) (not (free-id=? (syntax pat) x)))
- (cons (syntax (... ...)) keys)))
- (let ((labels (list (gen-label)))
- (var (gen-var (syntax pat))))
- (build-application no-source
- (build-lambda no-source
- (list (syntax->datum (syntax pat))) (list var)
- #f
- (chi (syntax exp)
- (extend-env labels
- (list (make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap (syntax (pat))
- labels empty-wrap)
- mod))
- (list x)))
- (gen-clause x keys (cdr clauses) r
- (syntax pat) #t (syntax exp) mod)))
- ((pat fender exp)
- (gen-clause x keys (cdr clauses) r
- (syntax pat) (syntax fender) (syntax exp) mod))
- (_ (syntax-violation 'syntax-case "invalid clause"
- (car clauses)))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ val (key ...) m ...)
- (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
- (syntax (key ...)))
- (let ((x (gen-var 'tmp)))
- ; fat finger binding and references to temp variable x
- (build-application s
- (build-lambda no-source (list 'tmp) (list x) #f
- (gen-syntax-case (build-lexical-reference 'value no-source
- 'tmp x)
- (syntax (key ...)) (syntax (m ...))
- r
- mod))
- (list (chi (syntax val) r empty-wrap mod))))
- (syntax-violation 'syntax-case "invalid literals list" e))))))))
-
-;;; The portable sc-expand seeds chi-top's mode m with 'e (for
-;;; evaluating) and esew (which stands for "eval syntax expanders
-;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
-;;; if we are compiling a file, and esew is set to
-;;; (eval-syntactic-expanders-when), which defaults to the list
-;;; '(compile load eval). This means that, by default, top-level
-;;; syntactic definitions are evaluated immediately after they are
-;;; expanded, and the expanded definitions are also residualized into
-;;; the object file if we are compiling a file.
-(set! sc-expand
- (lambda (x . rest)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (let ((m (if (null? rest) 'e (car rest)))
- (esew (if (or (null? rest) (null? (cdr rest)))
- '(eval)
- (cadr rest))))
- (with-fluid* *mode* m
- (lambda ()
- (chi-top x null-env top-wrap m esew
- (cons 'hygiene (module-name (current-module))))))))))
-
-(set! identifier?
- (lambda (x)
- (nonsymbol-id? x)))
-
-(set! datum->syntax
- (lambda (id datum)
- (make-syntax-object datum (syntax-object-wrap id) #f)))
-
-(set! syntax->datum
- ; accepts any object, since syntax objects may consist partially
- ; or entirely of unwrapped, nonsymbolic data
- (lambda (x)
- (strip x empty-wrap)))
-
-(set! generate-temporaries
- (lambda (ls)
- (arg-check list? ls 'generate-temporaries)
- (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
-
-(set! free-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'free-identifier=?)
- (arg-check nonsymbol-id? y 'free-identifier=?)
- (free-id=? x y)))
-
-(set! bound-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'bound-identifier=?)
- (arg-check nonsymbol-id? y 'bound-identifier=?)
- (bound-id=? x y)))
-
-(set! syntax-violation
- (lambda (who message form . subform)
- (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
- who 'syntax-violation)
- (arg-check string? message 'syntax-violation)
- (scm-error 'syntax-error 'sc-expand
- (string-append
- (if who "~a: " "")
- "~a "
- (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
- (let ((tail (cons message
- (map (lambda (x) (strip x empty-wrap))
- (append subform (list form))))))
- (if who (cons who tail) tail))
- #f)))
-
-;;; $sc-dispatch expects an expression and a pattern. If the expression
-;;; matches the pattern a list of the matching expressions for each
-;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
-;;; not work on r4rs implementations that violate the ieee requirement
-;;; that #f and () be distinct.)
-
-;;; The expression is matched with the pattern as follows:
-
-;;; pattern: matches:
-;;; () empty list
-;;; any anything
-;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
-;;; each-any (any*)
-;;; #(free-id <key>) <key> with free-identifier=?
-;;; #(each <pattern>) (<pattern>*)
-;;; #(vector <pattern>) (list->vector <pattern>)
-;;; #(atom <object>) <object> with "equal?"
-
-;;; Vector cops out to pair under assumption that vectors are rare. If
-;;; not, should convert to:
-;;; #(vector <pattern>*) #(<pattern>*)
-
-(let ()
-
-(define match-each
- (lambda (e p w mod)
- (cond
- ((pair? e)
- (let ((first (match (car e) p w '() mod)))
- (and first
- (let ((rest (match-each (cdr e) p w mod)))
- (and rest (cons first rest))))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))
- (syntax-object-module e)))
- (else #f))))
-
-(define match-each-any
- (lambda (e w mod)
- (cond
- ((pair? e)
- (let ((l (match-each-any (cdr e) w mod)))
- (and l (cons (wrap (car e) w mod) l))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))
- mod))
- (else #f))))
-
-(define match-empty
- (lambda (p r)
- (cond
- ((null? p) r)
- ((eq? p 'any) (cons '() r))
- ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
- ((eq? p 'each-any) (cons '() r))
- (else
- (case (vector-ref p 0)
- ((each) (match-empty (vector-ref p 1) r))
- ((free-id atom) r)
- ((vector) (match-empty (vector-ref p 1) r)))))))
-
-(define match*
- (lambda (e p w r mod)
- (cond
- ((null? p) (and (null? e) r))
- ((pair? p)
- (and (pair? e) (match (car e) (car p) w
- (match (cdr e) (cdr p) w r mod)
- mod)))
- ((eq? p 'each-any)
- (let ((l (match-each-any e w mod))) (and l (cons l r))))
- (else
- (case (vector-ref p 0)
- ((each)
- (if (null? e)
- (match-empty (vector-ref p 1) r)
- (let ((l (match-each e (vector-ref p 1) w mod)))
- (and l
- (let collect ((l l))
- (if (null? (car l))
- r
- (cons (map car l) (collect (map cdr l)))))))))
- ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
- ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
- ((vector)
- (and (vector? e)
- (match (vector->list e) (vector-ref p 1) w r mod))))))))
-
-(define match
- (lambda (e p w r mod)
- (cond
- ((not r) #f)
- ((eq? p 'any) (cons (wrap e w mod) r))
- ((syntax-object? e)
- (match*
- (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))
- r
- (syntax-object-module e)))
- (else (match* e p w r mod)))))
-
-(set! $sc-dispatch
- (lambda (e p)
- (cond
- ((eq? p 'any) (list e))
- ((syntax-object? e)
- (match* (syntax-object-expression e)
- p (syntax-object-wrap e) '() (syntax-object-module e)))
- (else (match* e p empty-wrap '() #f)))))
-
-))
-)
-
-(define-syntax with-syntax
- (lambda (x)
- (syntax-case x ()
- ((_ () e1 e2 ...)
- (syntax (begin e1 e2 ...)))
- ((_ ((out in)) e1 e2 ...)
- (syntax (syntax-case in () (out (begin e1 e2 ...)))))
- ((_ ((out in) ...) e1 e2 ...)
- (syntax (syntax-case (list in ...) ()
- ((out ...) (begin e1 e2 ...))))))))
-
-(define-syntax syntax-rules
- (lambda (x)
- (syntax-case x ()
- ((_ (k ...) ((keyword . pattern) template) ...)
- (syntax (lambda (x)
- (syntax-case x (k ...)
- ((dummy . pattern) (syntax template))
- ...)))))))
-
-(define-syntax let*
- (lambda (x)
- (syntax-case x ()
- ((let* ((x v) ...) e1 e2 ...)
- (and-map identifier? (syntax (x ...)))
- (let f ((bindings (syntax ((x v) ...))))
- (if (null? bindings)
- (syntax (let () e1 e2 ...))
- (with-syntax ((body (f (cdr bindings)))
- (binding (car bindings)))
- (syntax (let (binding) body)))))))))
-
-(define-syntax do
- (lambda (orig-x)
- (syntax-case orig-x ()
- ((_ ((var init . step) ...) (e0 e1 ...) c ...)
- (with-syntax (((step ...)
- (map (lambda (v s)
- (syntax-case s ()
- (() v)
- ((e) (syntax e))
- (_ (syntax-violation
- 'do "bad step expression"
- orig-x s))))
- (syntax (var ...))
- (syntax (step ...)))))
- (syntax-case (syntax (e1 ...)) ()
- (() (syntax (let doloop ((var init) ...)
- (if (not e0)
- (begin c ... (doloop step ...))))))
- ((e1 e2 ...)
- (syntax (let doloop ((var init) ...)
- (if e0
- (begin e1 e2 ...)
- (begin c ... (doloop step ...))))))))))))
-
-(define-syntax quasiquote
- (letrec
- ((quasicons
- (lambda (x y)
- (with-syntax ((x x) (y y))
- (syntax-case (syntax y) (quote list)
- ((quote dy)
- (syntax-case (syntax x) (quote)
- ((quote dx) (syntax (quote (dx . dy))))
- (_ (if (null? (syntax dy))
- (syntax (list x))
- (syntax (cons x y))))))
- ((list . stuff) (syntax (list x . stuff)))
- (else (syntax (cons x y)))))))
- (quasiappend
- (lambda (x y)
- (with-syntax ((x x) (y y))
- (syntax-case (syntax y) (quote)
- ((quote ()) (syntax x))
- (_ (syntax (append x y)))))))
- (quasivector
- (lambda (x)
- (with-syntax ((x x))
- (syntax-case (syntax x) (quote list)
- ((quote (x ...)) (syntax (quote #(x ...))))
- ((list x ...) (syntax (vector x ...)))
- (_ (syntax (list->vector x)))))))
- (quasi
- (lambda (p lev)
- (syntax-case p (unquote unquote-splicing quasiquote)
- ((unquote p)
- (if (= lev 0)
- (syntax p)
- (quasicons (syntax (quote unquote))
- (quasi (syntax (p)) (- lev 1)))))
- ((unquote . args)
- (= lev 0)
- (syntax-violation 'unquote
- "unquote takes exactly one argument"
- p (syntax (unquote . args))))
- (((unquote-splicing p) . q)
- (if (= lev 0)
- (quasiappend (syntax p) (quasi (syntax q) lev))
- (quasicons (quasicons (syntax (quote unquote-splicing))
- (quasi (syntax (p)) (- lev 1)))
- (quasi (syntax q) lev))))
- (((unquote-splicing . args) . q)
- (= lev 0)
- (syntax-violation 'unquote-splicing
- "unquote-splicing takes exactly one argument"
- p (syntax (unquote-splicing . args))))
- ((quasiquote p)
- (quasicons (syntax (quote quasiquote))
- (quasi (syntax (p)) (+ lev 1))))
- ((p . q)
- (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
- (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
- (p (syntax (quote p)))))))
- (lambda (x)
- (syntax-case x ()
- ((_ e) (quasi (syntax e) 0))))))
-
-(define-syntax include
- (lambda (x)
- (define read-file
- (lambda (fn k)
- (let ((p (open-input-file fn)))
- (let f ((x (read p)))
- (if (eof-object? x)
- (begin (close-input-port p) '())
- (cons (datum->syntax k x)
- (f (read p))))))))
- (syntax-case x ()
- ((k filename)
- (let ((fn (syntax->datum (syntax filename))))
- (with-syntax (((exp ...) (read-file fn (syntax k))))
- (syntax (begin exp ...))))))))
-
-(define-syntax unquote
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (syntax-violation 'unquote
- "expression not valid outside of quasiquote"
- x)))))
-
-(define-syntax unquote-splicing
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (syntax-violation 'unquote-splicing
- "expression not valid outside of quasiquote"
- x)))))
-
-(define-syntax case
- (lambda (x)
- (syntax-case x ()
- ((_ e m1 m2 ...)
- (with-syntax
- ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
- (if (null? clauses)
- (syntax-case clause (else)
- ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-violation 'case "bad clause" x clause)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else)
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...))
- (begin e1 e2 ...)
- rest)))
- (_ (syntax-violation 'case "bad clause" x
- clause))))))))
- (syntax (let ((t e)) body)))))))
-
-(define-syntax identifier-syntax
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (syntax
- (lambda (x)
- (syntax-case x ()
- (id
- (identifier? (syntax id))
- (syntax e))
- ((_ x (... ...))
- (syntax (e x (... ...)))))))))))
+;;;; -*-scheme-*-
+;;;;
+;;;; Copyright (C) 2001, 2003, 2006, 2009 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
+;;;;
+\f
+
+;;; Portable implementation of syntax-case
+;;; Extracted from Chez Scheme Version 5.9f
+;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+
+;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
+;;; revision control logs corresponding to this file: 2009.
+
+;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
+;;; to the ChangeLog distributed in the same directory as this file:
+;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
+;;; 2000-09-12, 2001-03-08
+
+;;; Copyright (c) 1992-1997 Cadence Research Systems
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright notice in full. This software
+;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
+;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
+;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
+;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
+;;; NATURE WHATSOEVER.
+
+;;; Before attempting to port this code to a new implementation of
+;;; Scheme, please read the notes below carefully.
+
+
+;;; This file defines the syntax-case expander, sc-expand, and a set
+;;; of associated syntactic forms and procedures. Of these, the
+;;; following are documented in The Scheme Programming Language,
+;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996). Most are
+;;; also documented in the R4RS and draft R5RS.
+;;;
+;;; bound-identifier=?
+;;; datum->syntax
+;;; define-syntax
+;;; fluid-let-syntax
+;;; free-identifier=?
+;;; generate-temporaries
+;;; identifier?
+;;; identifier-syntax
+;;; let-syntax
+;;; letrec-syntax
+;;; syntax
+;;; syntax-case
+;;; syntax->datum
+;;; syntax-rules
+;;; with-syntax
+;;;
+;;; All standard Scheme syntactic forms are supported by the expander
+;;; or syntactic abstractions defined in this file. Only the R4RS
+;;; delay is omitted, since its expansion is implementation-dependent.
+
+;;; The remaining exports are listed below:
+;;;
+;;; (sc-expand datum)
+;;; if datum represents a valid expression, sc-expand returns an
+;;; expanded version of datum in a core language that includes no
+;;; syntactic abstractions. The core language includes begin,
+;;; define, if, lambda, letrec, quote, and set!.
+;;; (eval-when situations expr ...)
+;;; conditionally evaluates expr ... at compile-time or run-time
+;;; depending upon situations (see the Chez Scheme System Manual,
+;;; Revision 3, for a complete description)
+;;; (syntax-violation who message form [subform])
+;;; used to report errors found during expansion
+;;; ($sc-dispatch e p)
+;;; used by expanded code to handle syntax-case matching
+
+;;; The following nonstandard procedures must be provided by the
+;;; implementation for this code to run using the standard portable
+;;; hooks and output constructors. They are not used by expanded code,
+;;; and so need be present only at expansion time.
+;;;
+;;; (eval x)
+;;; where x is always in the form ("noexpand" expr).
+;;; returns the value of expr. the "noexpand" flag is used to tell the
+;;; evaluator/expander that no expansion is necessary, since expr has
+;;; already been fully expanded to core forms.
+;;;
+;;; eval will not be invoked during the loading of psyntax.pp. After
+;;; psyntax.pp has been loaded, the expansion of any macro definition,
+;;; whether local or global, will result in a call to eval. If, however,
+;;; sc-expand has already been registered as the expander to be used
+;;; by eval, and eval accepts one argument, nothing special must be done
+;;; to support the "noexpand" flag, since it is handled by sc-expand.
+;;;
+;;; (gensym)
+;;; returns a unique symbol each time it's called
+
+;;; When porting to a new Scheme implementation, you should define the
+;;; procedures listed above, load the expanded version of psyntax.ss
+;;; (psyntax.pp, which should be available whereever you found
+;;; psyntax.ss), and register sc-expand as the current expander (how
+;;; you do this depends upon your implementation of Scheme). You may
+;;; change the hooks and constructors defined toward the beginning of
+;;; the code below, but to avoid bootstrapping problems, do so only
+;;; after you have a working version of the expander.
+
+;;; Chez Scheme allows the syntactic form (syntax <template>) to be
+;;; abbreviated to #'<template>, just as (quote <datum>) may be
+;;; abbreviated to '<datum>. The #' syntax makes programs written
+;;; using syntax-case shorter and more readable and draws out the
+;;; intuitive connection between syntax and quote.
+
+;;; If you find that this code loads or runs slowly, consider
+;;; switching to faster hardware or a faster implementation of
+;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
+;;; compiling (with full optimization), and loading this file takes
+;;; between one and two seconds.
+
+;;; In the expander implementation, we sometimes use syntactic abstractions
+;;; when procedural abstractions would suffice. For example, we define
+;;; top-wrap and top-marked? as
+;;; (define-syntax top-wrap (identifier-syntax '((top))))
+;;; (define-syntax top-marked?
+;;; (syntax-rules ()
+;;; ((_ w) (memq 'top (wrap-marks w)))))
+;;; rather than
+;;; (define top-wrap '((top)))
+;;; (define top-marked?
+;;; (lambda (w) (memq 'top (wrap-marks w))))
+;;; On ther other hand, we don't do this consistently; we define make-wrap,
+;;; wrap-marks, and wrap-subst simply as
+;;; (define make-wrap cons)
+;;; (define wrap-marks car)
+;;; (define wrap-subst cdr)
+;;; In Chez Scheme, the syntactic and procedural forms of these
+;;; abstractions are equivalent, since the optimizer consistently
+;;; integrates constants and small procedures. Some Scheme
+;;; implementations, however, may benefit from more consistent use
+;;; of one form or the other.
+
+
+;;; implementation information:
+
+;;; "begin" is treated as a splicing construct at top level and at
+;;; the beginning of bodies. Any sequence of expressions that would
+;;; be allowed where the "begin" occurs is allowed.
+
+;;; "let-syntax" and "letrec-syntax" are also treated as splicing
+;;; constructs, in violation of the R4RS appendix and probably the R5RS
+;;; when it comes out. A consequence, let-syntax and letrec-syntax do
+;;; not create local contours, as do let and letrec. Although the
+;;; functionality is greater as it is presently implemented, we will
+;;; probably change it to conform to the R4RS/expected R5RS.
+
+;;; Objects with no standard print syntax, including objects containing
+;;; cycles and syntax object, are allowed in quoted data as long as they
+;;; are contained within a syntax form or produced by datum->syntax.
+;;; Such objects are never copied.
+
+;;; All identifiers that don't have macro definitions and are not bound
+;;; lexically are assumed to be global variables
+
+;;; Top-level definitions of macro-introduced identifiers are allowed.
+;;; This may not be appropriate for implementations in which the
+;;; model is that bindings are created by definitions, as opposed to
+;;; one in which initial values are assigned by definitions.
+
+;;; Top-level variable definitions of syntax keywords is not permitted.
+;;; Any solution allowing this would be kludgey and would yield
+;;; surprising results in some cases. We can provide an undefine-syntax
+;;; form. The questions is, should define be an implicit undefine-syntax?
+;;; We've decided no for now.
+
+;;; Identifiers and syntax objects are implemented as vectors for
+;;; portability. As a result, it is possible to "forge" syntax
+;;; objects.
+
+;;; The implementation of generate-temporaries assumes that it is possible
+;;; to generate globally unique symbols (gensyms).
+
+
+;;; Bootstrapping:
+
+;;; When changing syntax-object representations, it is necessary to support
+;;; both old and new syntax-object representations in id-var-name. It
+;;; should be sufficient to recognize old representations and treat
+;;; them as not lexically bound.
+
+
+
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
+(let ()
+;;; Private version of and-map that handles multiple lists.
+(define and-map*
+ (lambda (f first . rest)
+ (or (null? first)
+ (if (null? rest)
+ (let andmap ((first first))
+ (let ((x (car first)) (first (cdr first)))
+ (if (null? first)
+ (f x)
+ (and (f x) (andmap first)))))
+ (let andmap ((first first) (rest rest))
+ (let ((x (car first))
+ (xr (map car rest))
+ (first (cdr first))
+ (rest (map cdr rest)))
+ (if (null? first)
+ (apply f (cons x xr))
+ (and (apply f (cons x xr)) (andmap first rest)))))))))
+
+(define-syntax define-structure
+ (lambda (x)
+ (define construct-name
+ (lambda (template-identifier . args)
+ (datum->syntax
+ template-identifier
+ (string->symbol
+ (apply string-append
+ (map (lambda (x)
+ (if (string? x)
+ x
+ (symbol->string (syntax->datum x))))
+ args))))))
+ (syntax-case x ()
+ ((_ (name id1 ...))
+ (and-map identifier? #'(name id1 ...))
+ (with-syntax
+ ((constructor (construct-name #'name "make-" #'name))
+ (predicate (construct-name #'name #'name "?"))
+ ((access ...)
+ (map (lambda (x) (construct-name x #'name "-" x))
+ #'(id1 ...)))
+ ((assign ...)
+ (map (lambda (x)
+ (construct-name x "set-" #'name "-" x "!"))
+ #'(id1 ...)))
+ (structure-length
+ (+ (length #'(id1 ...)) 1))
+ ((index ...)
+ (let f ((i 1) (ids #'(id1 ...)))
+ (if (null? ids)
+ '()
+ (cons i (f (+ i 1) (cdr ids)))))))
+ #'(begin
+ (define constructor
+ (lambda (id1 ...)
+ (vector 'name id1 ... )))
+ (define predicate
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) structure-length)
+ (eq? (vector-ref x 0) 'name))))
+ (define access
+ (lambda (x)
+ (vector-ref x index)))
+ ...
+ (define assign
+ (lambda (x update)
+ (vector-set! x index update)))
+ ...))))))
+
+(let ()
+ (define noexpand "noexpand")
+ (define *mode* (make-fluid))
+
+;;; hooks to nonportable run-time helpers
+ (begin
+ (define fx+ +)
+ (define fx- -)
+ (define fx= =)
+ (define fx< <)
+
+ (define top-level-eval-hook
+ (lambda (x mod)
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
+
+ (define local-eval-hook
+ (lambda (x mod)
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
+
+ (define-syntax gensym-hook
+ (syntax-rules ()
+ ((_) (gensym))))
+
+ (define put-global-definition-hook
+ (lambda (symbol type val)
+ (let ((existing (let ((v (module-variable (current-module) symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (not (syncase-macro-type val))
+ val))))))
+ (module-define! (current-module)
+ symbol
+ (if existing
+ (make-extended-syncase-macro existing type val)
+ (make-syncase-macro type val))))))
+
+ (define get-global-definition-hook
+ (lambda (symbol module)
+ (if (and (not module) (current-module))
+ (warn "module system is booted, we should have a module" symbol))
+ (let ((v (module-variable (if module
+ (resolve-module (cdr module))
+ (current-module))
+ symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val) (syncase-macro-type val)
+ (cons (syncase-macro-type val)
+ (syncase-macro-binding val))))))))
+
+ )
+
+
+ (define (decorate-source e s)
+ (if (and (pair? e) s)
+ (set-source-properties! e s))
+ e)
+
+;;; output constructors
+ (define build-void
+ (lambda (source)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-void) source))
+ (else (decorate-source '(if #f #f) source)))))
+
+ (define build-application
+ (lambda (source fun-exp arg-exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
+ (else (decorate-source `(,fun-exp . ,arg-exps) source)))))
+
+ (define build-conditional
+ (lambda (source test-exp then-exp else-exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-conditional)
+ source test-exp then-exp else-exp))
+ (else (decorate-source
+ (if (equal? else-exp '(if #f #f))
+ `(if ,test-exp ,then-exp)
+ `(if ,test-exp ,then-exp ,else-exp))
+ source)))))
+
+ (define build-lexical-reference
+ (lambda (type source name var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-ref) source name var))
+ (else (decorate-source var source)))))
+
+ (define build-lexical-assignment
+ (lambda (source name var exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
+ (else (decorate-source `(set! ,var ,exp) source)))))
+
+ ;; Before modules are booted, we can't expand into data structures from
+ ;; (language tree-il) -- we need to give the evaluator the
+ ;; s-expressions that it understands natively. Actually the real truth
+ ;; of the matter is that the evaluator doesn't understand tree-il
+ ;; structures at all. So until we fix the evaluator, if ever, the
+ ;; conflation that we should use tree-il iff we are compiling
+ ;; holds true.
+ ;;
+ (define (analyze-variable mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont var)
+ (let ((kind (car mod))
+ (mod (cdr mod)))
+ (case kind
+ ((public) (modref-cont mod var #t))
+ ((private) (if (not (equal? mod (module-name (current-module))))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ ((bare) (bare-cont var))
+ ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
+ (module-variable (resolve-module mod) var))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ (else (syntax-violation #f "bad module kind" var mod))))))
+
+ (define build-global-reference
+ (lambda (source var mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
+ (else (decorate-source (list (if public? '@ '@@) mod var) source))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+ (else (decorate-source var source)))))))
+
+ (define build-global-assignment
+ (lambda (source var exp mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
+ (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var) ,exp) source))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+ (else (decorate-source `(set! ,var ,exp) source)))))))
+
+ ;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
+ ;; from working. Hack around it.
+ (define (maybe-name-value! name val)
+ (cond
+ (((@ (language tree-il) lambda?) val)
+ (let ((meta ((@ (language tree-il) lambda-meta) val)))
+ (if (not (assq 'name meta))
+ ((setter (@ (language tree-il) lambda-meta))
+ val
+ (acons 'name name meta)))))))
+
+ (define build-global-definition
+ (lambda (source var exp)
+ (case (fluid-ref *mode*)
+ ((c)
+ (maybe-name-value! var exp)
+ ((@ (language tree-il) make-toplevel-define) source var exp))
+ (else (decorate-source `(define ,var ,exp) source)))))
+
+ ;; Ideally we would have all lambdas be case lambdas, but that would
+ ;; need special support in the interpreter for the full capabilities
+ ;; of case-lambda, with optional and keyword args and else clauses.
+ ;; This will come with the new interpreter, but for now we separate
+ ;; the cases.
+ (define build-simple-lambda
+ (lambda (src req rest vars docstring exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src
+ (if docstring `((documentation . ,docstring)) '())
+ ;; hah, a case in which kwargs would be nice.
+ ((@ (language tree-il) make-lambda-case)
+ ;; src req opt rest kw inits vars body else
+ src req #f rest #f '() vars exp #f)))
+ (else (decorate-source
+ `(lambda ,(if rest (apply cons* vars) vars)
+ ,@(if docstring (list docstring) '())
+ ,exp)
+ src)))))
+ (define build-case-lambda
+ (lambda (src docstring body)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src
+ (if docstring `((documentation . ,docstring)) '())
+ body))
+ (else (decorate-source
+ ;; really gross hack
+ `(lambda %%args
+ ,@(if docstring (list docstring) '())
+ (cond ,@body))
+ src)))))
+
+ (define build-lambda-case
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw := (allow-other-keys? (keyword name var [init]) ...) | #f
+ ;; inits: (init ...)
+ ;; vars: (sym ...)
+ ;; vars map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ ;; the body of a lambda: anything, already expanded
+ ;; else: lambda-case | #f
+ (lambda (src req opt rest kw inits vars body else-case)
+ (case (fluid-ref *mode*)
+ ((c)
+ ((@ (language tree-il) make-lambda-case)
+ src req opt rest kw inits vars body else-case))
+ (else
+ ;; Very much like the logic of (language tree-il compile-glil).
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ ;; (,key ,name ,var)
+ (cons (car x) (list-index vars (caddr x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices)))))
+ (or (= nargs
+ (length vars)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "something went wrong"
+ req opt rest kw inits vars nreq nopt kw-indices nargs))
+ (decorate-source
+ `((((@@ (ice-9 optargs) parse-lambda-case)
+ '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+ (list ,@(map (lambda (i) `(lambda ,vars ,i)) inits))
+ %%args)
+ ;; FIXME: This _ is here to work around a bug in the
+ ;; memoizer. The %%% makes it different from %%, also a
+ ;; memoizer workaround. See the "interesting bug" mail from
+ ;; 23 oct 2009. As soon as we change the evaluator, this
+ ;; can be removed.
+ => (lambda (%%%args . _) (apply (lambda ,vars ,body) %%%args)))
+ ,@(or else-case
+ `((%%args (error "wrong number of arguments" %%args)))))
+ src))))))
+
+ (define build-primref
+ (lambda (src name)
+ (if (equal? (module-name (current-module)) '(guile))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) src name))
+ (else (decorate-source name src)))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
+ (else (decorate-source `(@@ (guile) ,name) src))))))
+
+ (define (build-data src exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-const) src exp))
+ (else (decorate-source
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp))
+ src))))
+
+ (define build-sequence
+ (lambda (src exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-sequence) src exps))
+ (else (decorate-source `(begin ,@exps) src))))))
+
+ (define build-let
+ (lambda (src ids vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
+ (else (decorate-source
+ `(let ,(map list vars val-exps) ,body-exp)
+ src))))))
+
+ (define build-named-let
+ (lambda (src ids vars val-exps body-exp)
+ (let ((f (car vars))
+ (f-name (car ids))
+ (vars (cdr vars))
+ (ids (cdr ids)))
+ (case (fluid-ref *mode*)
+ ((c)
+ (let ((proc (build-simple-lambda src ids #f vars #f body-exp)))
+ (maybe-name-value! f-name proc)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-letrec) src
+ (list f-name) (list f) (list proc)
+ (build-application src (build-lexical-reference 'fun src f-name f)
+ val-exps))))
+ (else (decorate-source
+ `(letrec ((,f (lambda ,vars ,body-exp)))
+ (,f ,@val-exps))
+ src))))))
+
+ (define build-letrec
+ (lambda (src ids vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
+ (else (decorate-source
+ `(letrec ,(map list vars val-exps) ,body-exp)
+ src))))))
+
+ ;; FIXME: use a faster gensym
+ (define-syntax build-lexical-var
+ (syntax-rules ()
+ ((_ src id) (gensym (string-append (symbol->string id) " ")))))
+
+ (define-structure (syntax-object expression wrap module))
+
+ (define-syntax no-source (identifier-syntax #f))
+
+ (define source-annotation
+ (lambda (x)
+ (cond
+ ((syntax-object? x)
+ (source-annotation (syntax-object-expression x)))
+ ((pair? x) (let ((props (source-properties x)))
+ (if (pair? props)
+ props
+ #f)))
+ (else #f))))
+
+ (define-syntax arg-check
+ (syntax-rules ()
+ ((_ pred? e who)
+ (let ((x e))
+ (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
+
+;;; compile-time environments
+
+;;; wrap and environment comprise two level mapping.
+;;; wrap : id --> label
+;;; env : label --> <element>
+
+;;; environments are represented in two parts: a lexical part and a global
+;;; part. The lexical part is a simple list of associations from labels
+;;; to bindings. The global part is implemented by
+;;; {put,get}-global-definition-hook and associates symbols with
+;;; bindings.
+
+;;; global (assumed global variable) and displaced-lexical (see below)
+;;; do not show up in any environment; instead, they are fabricated by
+;;; lookup when it finds no other bindings.
+
+;;; <environment> ::= ((<label> . <binding>)*)
+
+;;; identifier bindings include a type and a value
+
+;;; <binding> ::= (macro . <procedure>) macros
+;;; (core . <procedure>) core forms
+;;; (module-ref . <procedure>) @ or @@
+;;; (begin) begin
+;;; (define) define
+;;; (define-syntax) define-syntax
+;;; (local-syntax . rec?) let-syntax/letrec-syntax
+;;; (eval-when) eval-when
+;;; #'. (<var> . <level>) pattern variables
+;;; (global) assumed global variable
+;;; (lexical . <var>) lexical variables
+;;; (displaced-lexical) displaced lexicals
+;;; <level> ::= <nonnegative integer>
+;;; <var> ::= variable returned by build-lexical-var
+
+;;; a macro is a user-defined syntactic-form. a core is a system-defined
+;;; syntactic form. begin, define, define-syntax, and eval-when are
+;;; treated specially since they are sensitive to whether the form is
+;;; at top-level and (except for eval-when) can denote valid internal
+;;; definitions.
+
+;;; a pattern variable is a variable introduced by syntax-case and can
+;;; be referenced only within a syntax form.
+
+;;; any identifier for which no top-level syntax definition or local
+;;; binding of any kind has been seen is assumed to be a global
+;;; variable.
+
+;;; a lexical variable is a lambda- or letrec-bound variable.
+
+;;; a displaced-lexical identifier is a lexical identifier removed from
+;;; it's scope by the return of a syntax object containing the identifier.
+;;; a displaced lexical can also appear when a letrec-syntax-bound
+;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
+;;; a displaced lexical should never occur with properly written macros.
+
+ (define-syntax make-binding
+ (syntax-rules (quote)
+ ((_ type value) (cons type value))
+ ((_ 'type) '(type))
+ ((_ type) (cons type '()))))
+ (define binding-type car)
+ (define binding-value cdr)
+
+ (define-syntax null-env (identifier-syntax '()))
+
+ (define extend-env
+ (lambda (labels bindings r)
+ (if (null? labels)
+ r
+ (extend-env (cdr labels) (cdr bindings)
+ (cons (cons (car labels) (car bindings)) r)))))
+
+ (define extend-var-env
+ ; variant of extend-env that forms "lexical" binding
+ (lambda (labels vars r)
+ (if (null? labels)
+ r
+ (extend-var-env (cdr labels) (cdr vars)
+ (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
+
+;;; we use a "macros only" environment in expansion of local macro
+;;; definitions so that their definitions can use local macros without
+;;; attempting to use other lexical identifiers.
+ (define macros-only-env
+ (lambda (r)
+ (if (null? r)
+ '()
+ (let ((a (car r)))
+ (if (eq? (cadr a) 'macro)
+ (cons a (macros-only-env (cdr r)))
+ (macros-only-env (cdr r)))))))
+
+ (define lookup
+ ; x may be a label or a symbol
+ ; although symbols are usually global, we check the environment first
+ ; anyway because a temporary binding may have been established by
+ ; fluid-let-syntax
+ (lambda (x r mod)
+ (cond
+ ((assq x r) => cdr)
+ ((symbol? x)
+ (or (get-global-definition-hook x mod) (make-binding 'global)))
+ (else (make-binding 'displaced-lexical)))))
+
+ (define global-extend
+ (lambda (type sym val)
+ (put-global-definition-hook sym type val)))
+
+
+;;; Conceptually, identifiers are always syntax objects. Internally,
+;;; however, the wrap is sometimes maintained separately (a source of
+;;; efficiency and confusion), so that symbols are also considered
+;;; identifiers by id?. Externally, they are always wrapped.
+
+ (define nonsymbol-id?
+ (lambda (x)
+ (and (syntax-object? x)
+ (symbol? (syntax-object-expression x)))))
+
+ (define id?
+ (lambda (x)
+ (cond
+ ((symbol? x) #t)
+ ((syntax-object? x) (symbol? (syntax-object-expression x)))
+ (else #f))))
+
+ (define-syntax id-sym-name
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (if (syntax-object? x)
+ (syntax-object-expression x)
+ x)))))
+
+ (define id-sym-name&marks
+ (lambda (x w)
+ (if (syntax-object? x)
+ (values
+ (syntax-object-expression x)
+ (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (values x (wrap-marks w)))))
+
+;;; syntax object wraps
+
+;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+;;; <subst> ::= <shift> | <subs>
+;;; <subs> ::= #(<old name> <label> (<mark> ...))
+;;; <shift> ::= positive fixnum
+
+ (define make-wrap cons)
+ (define wrap-marks car)
+ (define wrap-subst cdr)
+
+ (define-syntax subst-rename? (identifier-syntax vector?))
+ (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
+ (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
+ (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
+ (define-syntax make-rename
+ (syntax-rules ()
+ ((_ old new marks) (vector old new marks))))
+
+;;; labels must be comparable with "eq?" and distinct from symbols.
+ (define gen-label
+ (lambda () (string #\i)))
+
+ (define gen-labels
+ (lambda (ls)
+ (if (null? ls)
+ '()
+ (cons (gen-label) (gen-labels (cdr ls))))))
+
+ (define-structure (ribcage symnames marks labels))
+
+ (define-syntax empty-wrap (identifier-syntax '(())))
+
+ (define-syntax top-wrap (identifier-syntax '((top))))
+
+ (define-syntax top-marked?
+ (syntax-rules ()
+ ((_ w) (memq 'top (wrap-marks w)))))
+
+;;; Marks must be comparable with "eq?" and distinct from pairs and
+;;; the symbol top. We do not use integers so that marks will remain
+;;; unique even across file compiles.
+
+ (define-syntax the-anti-mark (identifier-syntax #f))
+
+ (define anti-mark
+ (lambda (w)
+ (make-wrap (cons the-anti-mark (wrap-marks w))
+ (cons 'shift (wrap-subst w)))))
+
+ (define-syntax new-mark
+ (syntax-rules ()
+ ((_) (string #\m))))
+
+;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
+;;; internal definitions, in which the ribcages are built incrementally
+ (define-syntax make-empty-ribcage
+ (syntax-rules ()
+ ((_) (make-ribcage '() '() '()))))
+
+ (define extend-ribcage!
+ ; must receive ids with complete wraps
+ (lambda (ribcage id label)
+ (set-ribcage-symnames! ribcage
+ (cons (syntax-object-expression id)
+ (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks (syntax-object-wrap id))
+ (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage
+ (cons label (ribcage-labels ribcage)))))
+
+;;; make-binding-wrap creates vector-based ribcages
+ (define make-binding-wrap
+ (lambda (ids labels w)
+ (if (null? ids)
+ w
+ (make-wrap
+ (wrap-marks w)
+ (cons
+ (let ((labelvec (list->vector labels)))
+ (let ((n (vector-length labelvec)))
+ (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
+ (let f ((ids ids) (i 0))
+ (if (not (null? ids))
+ (call-with-values
+ (lambda () (id-sym-name&marks (car ids) w))
+ (lambda (symname marks)
+ (vector-set! symnamevec i symname)
+ (vector-set! marksvec i marks)
+ (f (cdr ids) (fx+ i 1))))))
+ (make-ribcage symnamevec marksvec labelvec))))
+ (wrap-subst w))))))
+
+ (define smart-append
+ (lambda (m1 m2)
+ (if (null? m2)
+ m1
+ (append m1 m2))))
+
+ (define join-wraps
+ (lambda (w1 w2)
+ (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
+ (if (null? m1)
+ (if (null? s1)
+ w2
+ (make-wrap
+ (wrap-marks w2)
+ (smart-append s1 (wrap-subst w2))))
+ (make-wrap
+ (smart-append m1 (wrap-marks w2))
+ (smart-append s1 (wrap-subst w2)))))))
+
+ (define join-marks
+ (lambda (m1 m2)
+ (smart-append m1 m2)))
+
+ (define same-marks?
+ (lambda (x y)
+ (or (eq? x y)
+ (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y))
+ (same-marks? (cdr x) (cdr y))))))
+
+ (define id-var-name
+ (lambda (id w)
+ (define-syntax first
+ (syntax-rules ()
+ ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
+ (define search
+ (lambda (sym subst marks)
+ (if (null? subst)
+ (values #f marks)
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (search sym (cdr subst) (cdr marks))
+ (let ((symnames (ribcage-symnames fst)))
+ (if (vector? symnames)
+ (search-vector-rib sym subst marks symnames fst)
+ (search-list-rib sym subst marks symnames fst))))))))
+ (define search-list-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let f ((symnames symnames) (i 0))
+ (cond
+ ((null? symnames) (search sym (cdr subst) marks))
+ ((and (eq? (car symnames) sym)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values (list-ref (ribcage-labels ribcage) i) marks))
+ (else (f (cdr symnames) (fx+ i 1)))))))
+ (define search-vector-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0))
+ (cond
+ ((fx= i n) (search sym (cdr subst) marks))
+ ((and (eq? (vector-ref symnames i) sym)
+ (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
+ (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (else (f (fx+ i 1))))))))
+ (cond
+ ((symbol? id)
+ (or (first (search id (wrap-subst w) (wrap-marks w))) id))
+ ((syntax-object? id)
+ (let ((id (syntax-object-expression id))
+ (w1 (syntax-object-wrap id)))
+ (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
+ (call-with-values (lambda () (search id (wrap-subst w) marks))
+ (lambda (new-id marks)
+ (or new-id
+ (first (search id (wrap-subst w1) marks))
+ id))))))
+ (else (syntax-violation 'id-var-name "invalid id" id)))))
+
+;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
+;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
+
+ (define free-id=?
+ (lambda (i j)
+ (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
+ (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
+
+;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
+;;; long as the missing portion of the wrap is common to both of the ids
+;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
+
+ (define bound-id=?
+ (lambda (i j)
+ (if (and (syntax-object? i) (syntax-object? j))
+ (and (eq? (syntax-object-expression i)
+ (syntax-object-expression j))
+ (same-marks? (wrap-marks (syntax-object-wrap i))
+ (wrap-marks (syntax-object-wrap j))))
+ (eq? i j))))
+
+;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
+;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
+;;; as long as the missing portion of the wrap is common to all of the
+;;; ids.
+
+ (define valid-bound-ids?
+ (lambda (ids)
+ (and (let all-ids? ((ids ids))
+ (or (null? ids)
+ (and (id? (car ids))
+ (all-ids? (cdr ids)))))
+ (distinct-bound-ids? ids))))
+
+;;; distinct-bound-ids? expects a list of ids and returns #t if there are
+;;; no duplicates. It is quadratic on the length of the id list; long
+;;; lists could be sorted to make it more efficient. distinct-bound-ids?
+;;; may be passed unwrapped (or partially wrapped) ids as long as the
+;;; missing portion of the wrap is common to all of the ids.
+
+ (define distinct-bound-ids?
+ (lambda (ids)
+ (let distinct? ((ids ids))
+ (or (null? ids)
+ (and (not (bound-id-member? (car ids) (cdr ids)))
+ (distinct? (cdr ids)))))))
+
+ (define bound-id-member?
+ (lambda (x list)
+ (and (not (null? list))
+ (or (bound-id=? x (car list))
+ (bound-id-member? x (cdr list))))))
+
+;;; wrapping expressions and identifiers
+
+ (define wrap
+ (lambda (x w defmod)
+ (cond
+ ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
+ ((syntax-object? x)
+ (make-syntax-object
+ (syntax-object-expression x)
+ (join-wraps w (syntax-object-wrap x))
+ (syntax-object-module x)))
+ ((null? x) x)
+ (else (make-syntax-object x w defmod)))))
+
+ (define source-wrap
+ (lambda (x w s defmod)
+ (wrap (decorate-source x s) w defmod)))
+
+;;; expanding
+
+ (define chi-sequence
+ (lambda (body r w s mod)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w) (mod mod))
+ (if (null? body)
+ '()
+ (let ((first (chi (car body) r w mod)))
+ (cons first (dobody (cdr body) r w mod))))))))
+
+ (define chi-top-sequence
+ (lambda (body r w s m esew mod)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
+ (if (null? body)
+ '()
+ (let ((first (chi-top (car body) r w m esew mod)))
+ (cons first (dobody (cdr body) r w m esew mod))))))))
+
+ (define chi-install-global
+ (lambda (name e)
+ (build-global-definition
+ no-source
+ name
+ ;; FIXME: seems nasty to call current-module here
+ (if (let ((v (module-variable (current-module) name)))
+ ;; FIXME use primitive-macro?
+ (and v (variable-bound? v) (macro? (variable-ref v))
+ (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
+ (build-application
+ no-source
+ (build-primref no-source 'make-extended-syncase-macro)
+ (list (build-application
+ no-source
+ (build-primref no-source 'module-ref)
+ (list (build-application
+ no-source
+ (build-primref no-source 'current-module)
+ '())
+ (build-data no-source name)))
+ (build-data no-source 'macro)
+ (build-application
+ no-source
+ (build-primref no-source 'cons)
+ (list e
+ (build-application
+ no-source
+ (build-primref no-source 'module-name)
+ (list (build-application
+ no-source
+ (build-primref no-source 'current-module)
+ '())))))))
+ (build-application
+ no-source
+ (build-primref no-source 'make-syncase-macro)
+ (list (build-data no-source 'macro)
+ (build-application
+ no-source
+ (build-primref no-source 'cons)
+ (list e
+ (build-application
+ no-source
+ (build-primref no-source 'module-name)
+ (list (build-application
+ no-source
+ (build-primref no-source 'current-module)
+ '())))))))))))
+
+ (define chi-when-list
+ (lambda (e when-list w)
+ ; when-list is syntax'd version of list of situations
+ (let f ((when-list when-list) (situations '()))
+ (if (null? when-list)
+ situations
+ (f (cdr when-list)
+ (cons (let ((x (car when-list)))
+ (cond
+ ((free-id=? x #'compile) 'compile)
+ ((free-id=? x #'load) 'load)
+ ((free-id=? x #'eval) 'eval)
+ (else (syntax-violation 'eval-when
+ "invalid situation"
+ e (wrap x w #f)))))
+ situations))))))
+
+;;; syntax-type returns six values: type, value, e, w, s, and mod. The
+;;; first two are described in the table below.
+;;;
+;;; type value explanation
+;;; -------------------------------------------------------------------
+;;; core procedure core singleton
+;;; core-form procedure core form
+;;; module-ref procedure @ or @@ singleton
+;;; lexical name lexical variable reference
+;;; global name global variable reference
+;;; begin none begin keyword
+;;; define none define keyword
+;;; define-syntax none define-syntax keyword
+;;; local-syntax rec? letrec-syntax/let-syntax keyword
+;;; eval-when none eval-when keyword
+;;; syntax level pattern variable
+;;; displaced-lexical none displaced lexical identifier
+;;; lexical-call name call to lexical variable
+;;; global-call name call to global variable
+;;; call none any other call
+;;; begin-form none begin expression
+;;; define-form id variable definition
+;;; define-syntax-form id syntax definition
+;;; local-syntax-form rec? syntax definition
+;;; eval-when-form none eval-when form
+;;; constant none self-evaluating datum
+;;; other none anything else
+;;;
+;;; For define-form and define-syntax-form, e is the rhs expression.
+;;; For all others, e is the entire form. w is the wrap for e.
+;;; s is the source for the entire form. mod is the module for e.
+;;;
+;;; syntax-type expands macros and unwraps as necessary to get to
+;;; one of the forms above. It also parses define and define-syntax
+;;; forms, although perhaps this should be done by the consumer.
+
+ (define syntax-type
+ (lambda (e r w s rib mod for-car?)
+ (cond
+ ((symbol? e)
+ (let* ((n (id-var-name e w))
+ (b (lookup n r mod))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values type (binding-value b) e w s mod))
+ ((global) (values type n e w s mod))
+ ((macro)
+ (if for-car?
+ (values type (binding-value b) e w s mod)
+ (syntax-type (chi-macro (binding-value b) e r w rib mod)
+ r empty-wrap s rib mod #f)))
+ (else (values type (binding-value b) e w s mod)))))
+ ((pair? e)
+ (let ((first (car e)))
+ (call-with-values
+ (lambda () (syntax-type first r w s rib mod #t))
+ (lambda (ftype fval fe fw fs fmod)
+ (case ftype
+ ((lexical)
+ (values 'lexical-call fval e w s mod))
+ ((global)
+ ;; If we got here via an (@@ ...) expansion, we need to
+ ;; make sure the fmod information is propagated back
+ ;; correctly -- hence this consing.
+ (values 'global-call (make-syntax-object fval w fmod)
+ e w s mod))
+ ((macro)
+ (syntax-type (chi-macro fval e r w rib mod)
+ r empty-wrap s rib mod for-car?))
+ ((module-ref)
+ (call-with-values (lambda () (fval e))
+ (lambda (sym mod)
+ (syntax-type sym r w s rib mod for-car?))))
+ ((core)
+ (values 'core-form fval e w s mod))
+ ((local-syntax)
+ (values 'local-syntax-form fval e w s mod))
+ ((begin)
+ (values 'begin-form #f e w s mod))
+ ((eval-when)
+ (values 'eval-when-form #f e w s mod))
+ ((define)
+ (syntax-case e ()
+ ((_ name val)
+ (id? #'name)
+ (values 'define-form #'name #'val w s mod))
+ ((_ (name . args) e1 e2 ...)
+ (and (id? #'name)
+ (valid-bound-ids? (lambda-var-list #'args)))
+ ; need lambda here...
+ (values 'define-form (wrap #'name w mod)
+ (decorate-source
+ (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
+ s)
+ empty-wrap s mod))
+ ((_ name)
+ (id? #'name)
+ (values 'define-form (wrap #'name w mod)
+ #'(if #f #f)
+ empty-wrap s mod))))
+ ((define-syntax)
+ (syntax-case e ()
+ ((_ name val)
+ (id? #'name)
+ (values 'define-syntax-form #'name
+ #'val w s mod))))
+ (else
+ (values 'call #f e w s mod)))))))
+ ((syntax-object? e)
+ (syntax-type (syntax-object-expression e)
+ r
+ (join-wraps w (syntax-object-wrap e))
+ s rib (or (syntax-object-module e) mod) for-car?))
+ ((self-evaluating? e) (values 'constant #f e w s mod))
+ (else (values 'other #f e w s mod)))))
+
+ (define chi-top
+ (lambda (e r w m esew mod)
+ (define-syntax eval-if-c&e
+ (syntax-rules ()
+ ((_ m e mod)
+ (let ((x e))
+ (if (eq? m 'c&e) (top-level-eval-hook x mod))
+ x))))
+ (call-with-values
+ (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+ (lambda (type value e w s mod)
+ (case type
+ ((begin-form)
+ (syntax-case e ()
+ ((_) (chi-void))
+ ((_ e1 e2 ...)
+ (chi-top-sequence #'(e1 e2 ...) r w s m esew mod))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s mod
+ (lambda (body r w s mod)
+ (chi-top-sequence body r w s m esew mod))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e #'(x ...) w))
+ (body #'(e1 e2 ...)))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (chi-top-sequence body r w s 'e '(eval) mod)
+ (chi-void)))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (chi-top-sequence body r w s 'c&e '(compile load) mod)
+ (if (memq m '(c c&e))
+ (chi-top-sequence body r w s 'c '(load) mod)
+ (chi-void))))
+ ((or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (chi-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ (chi-void))
+ (else (chi-void)))))))
+ ((define-syntax-form)
+ (let ((n (id-var-name value w)) (r (macros-only-env r)))
+ (case m
+ ((c)
+ (if (memq 'compile esew)
+ (let ((e (chi-install-global n (chi e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew) e (chi-void)))
+ (if (memq 'load esew)
+ (chi-install-global n (chi e r w mod))
+ (chi-void))))
+ ((c&e)
+ (let ((e (chi-install-global n (chi e r w mod))))
+ (top-level-eval-hook e mod)
+ e))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (chi-install-global n (chi e r w mod))
+ mod))
+ (chi-void)))))
+ ((define-form)
+ (let* ((n (id-var-name value w))
+ (type (binding-type (lookup n r mod))))
+ (case type
+ ((global core macro module-ref)
+ ;; affect compile-time environment (once we have booted)
+ (if (and (not (module-local-variable (current-module) n))
+ (current-module))
+ (let ((old (module-variable (current-module) n)))
+ ;; use value of the same-named imported variable, if
+ ;; any
+ (module-define! (current-module) n
+ (if (variable? old)
+ (variable-ref old)
+ #f))))
+ (eval-if-c&e m
+ (build-global-definition s n (chi e r w mod))
+ mod))
+ ((displaced-lexical)
+ (syntax-violation #f "identifier out of context"
+ e (wrap value w mod)))
+ (else
+ (syntax-violation #f "cannot define keyword at top level"
+ e (wrap value w mod))))))
+ (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
+
+ (define chi
+ (lambda (e r w mod)
+ (call-with-values
+ (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+ (lambda (type value e w s mod)
+ (chi-expr type value e r w s mod)))))
+
+ (define chi-expr
+ (lambda (type value e r w s mod)
+ (case type
+ ((lexical)
+ (build-lexical-reference 'value s e value))
+ ((core core-form)
+ ;; apply transformer
+ (value e r w s mod))
+ ((module-ref)
+ (call-with-values (lambda () (value e))
+ ;; we could add a public? arg here
+ (lambda (id mod) (build-global-reference s id mod))))
+ ((lexical-call)
+ (chi-application
+ (build-lexical-reference 'fun (source-annotation (car e))
+ (car e) value)
+ e r w s mod))
+ ((global-call)
+ (chi-application
+ (build-global-reference (source-annotation (car e))
+ (if (syntax-object? value)
+ (syntax-object-expression value)
+ value)
+ (if (syntax-object? value)
+ (syntax-object-module value)
+ mod))
+ e r w s mod))
+ ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
+ ((global) (build-global-reference s value mod))
+ ((call) (chi-application (chi (car e) r w mod) e r w s mod))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s mod chi-sequence))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e #'(x ...) w)))
+ (if (memq 'eval when-list)
+ (chi-sequence #'(e1 e2 ...) r w s mod)
+ (chi-void))))))
+ ((define-form define-syntax-form)
+ (syntax-violation #f "definition in expression context"
+ e (wrap value w mod)))
+ ((syntax)
+ (syntax-violation #f "reference to pattern variable outside syntax form"
+ (source-wrap e w s mod)))
+ ((displaced-lexical)
+ (syntax-violation #f "reference to identifier outside its scope"
+ (source-wrap e w s mod)))
+ (else (syntax-violation #f "unexpected syntax"
+ (source-wrap e w s mod))))))
+
+ (define chi-application
+ (lambda (x e r w s mod)
+ (syntax-case e ()
+ ((e0 e1 ...)
+ (build-application s x
+ (map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
+
+ (define chi-macro
+ (lambda (p e r w rib mod)
+ ;; p := (procedure . module-name)
+ (define rebuild-macro-output
+ (lambda (x m)
+ (cond ((pair? x)
+ (cons (rebuild-macro-output (car x) m)
+ (rebuild-macro-output (cdr x) m)))
+ ((syntax-object? x)
+ (let ((w (syntax-object-wrap x)))
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ ;; output is from original text
+ (make-syntax-object
+ (syntax-object-expression x)
+ (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+ (syntax-object-module x))
+ ;; output introduced by macro
+ (make-syntax-object
+ (syntax-object-expression x)
+ (make-wrap (cons m ms)
+ (if rib
+ (cons rib (cons 'shift s))
+ (cons 'shift s)))
+ ;; hither the hygiene
+ (cons 'hygiene (cdr p)))))))
+
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i n) v)
+ (vector-set! v i
+ (rebuild-macro-output (vector-ref x i) m)))))
+ ((symbol? x)
+ (syntax-violation #f "encountered raw symbol in macro output"
+ (source-wrap e w (wrap-subst w) mod) x))
+ (else x))))
+ (rebuild-macro-output ((car p) (wrap e (anti-mark w) mod)) (new-mark))))
+
+ (define chi-body
+ ;; In processing the forms of the body, we create a new, empty wrap.
+ ;; This wrap is augmented (destructively) each time we discover that
+ ;; the next form is a definition. This is done:
+ ;;
+ ;; (1) to allow the first nondefinition form to be a call to
+ ;; one of the defined ids even if the id previously denoted a
+ ;; definition keyword or keyword for a macro expanding into a
+ ;; definition;
+ ;; (2) to prevent subsequent definition forms (but unfortunately
+ ;; not earlier ones) and the first nondefinition form from
+ ;; confusing one of the bound identifiers for an auxiliary
+ ;; keyword; and
+ ;; (3) so that we do not need to restart the expansion of the
+ ;; first nondefinition form, which is problematic anyway
+ ;; since it might be the first element of a begin that we
+ ;; have just spliced into the body (meaning if we restarted,
+ ;; we'd really need to restart with the begin or the macro
+ ;; call that expanded into the begin, and we'd have to give
+ ;; up allowing (begin <defn>+ <expr>+), which is itself
+ ;; problematic since we don't know if a begin contains only
+ ;; definitions until we've expanded it).
+ ;;
+ ;; Before processing the body, we also create a new environment
+ ;; containing a placeholder for the bindings we will add later and
+ ;; associate this environment with each form. In processing a
+ ;; let-syntax or letrec-syntax, the associated environment may be
+ ;; augmented with local keyword bindings, so the environment may
+ ;; be different for different forms in the body. Once we have
+ ;; gathered up all of the definitions, we evaluate the transformer
+ ;; expressions and splice into r at the placeholder the new variable
+ ;; and keyword bindings. This allows let-syntax or letrec-syntax
+ ;; forms local to a portion or all of the body to shadow the
+ ;; definition bindings.
+ ;;
+ ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
+ ;; into the body.
+ ;;
+ ;; outer-form is fully wrapped w/source
+ (lambda (body outer-form r w mod)
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+ (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
+ (ids '()) (labels '())
+ (var-ids '()) (vars '()) (vals '()) (bindings '()))
+ (if (null? body)
+ (syntax-violation #f "no expressions in body" outer-form)
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
+ (lambda (type value e w s mod)
+ (case type
+ ((define-form)
+ (let ((id (wrap value w mod)) (label (gen-label)))
+ (let ((var (gen-var id)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids) (cons label labels)
+ (cons id var-ids)
+ (cons var vars) (cons (cons er (wrap e w mod)) vals)
+ (cons (make-binding 'lexical var) bindings)))))
+ ((define-syntax-form)
+ (let ((id (wrap value w mod)) (label (gen-label)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids) (cons label labels)
+ var-ids vars vals
+ (cons (make-binding 'macro (cons er (wrap e w mod)))
+ bindings))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse (let f ((forms #'(e1 ...)))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w mod))
+ (f (cdr forms)))))
+ ids labels var-ids vars vals bindings))))
+ ((local-syntax-form)
+ (chi-local-syntax value e er w s mod
+ (lambda (forms er w s mod)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w mod))
+ (f (cdr forms)))))
+ ids labels var-ids vars vals bindings))))
+ (else ; found a non-definition
+ (if (null? ids)
+ (build-sequence no-source
+ (map (lambda (x)
+ (chi (cdr x) (car x) empty-wrap mod))
+ (cons (cons er (source-wrap e w s mod))
+ (cdr body))))
+ (begin
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation
+ #f "invalid or duplicate identifier in definition"
+ outer-form))
+ (let loop ((bs bindings) (er-cache #f) (r-cache #f))
+ (if (not (null? bs))
+ (let* ((b (car bs)))
+ (if (eq? (car b) 'macro)
+ (let* ((er (cadr b))
+ (r-cache
+ (if (eq? er er-cache)
+ r-cache
+ (macros-only-env er))))
+ (set-cdr! b
+ (eval-local-transformer
+ (chi (cddr b) r-cache empty-wrap mod)
+ mod))
+ (loop (cdr bs) er r-cache))
+ (loop (cdr bs) er-cache r-cache)))))
+ (set-cdr! r (extend-env labels bindings (cdr r)))
+ (build-letrec no-source
+ (map syntax->datum var-ids)
+ vars
+ (map (lambda (x)
+ (chi (cdr x) (car x) empty-wrap mod))
+ vals)
+ (build-sequence no-source
+ (map (lambda (x)
+ (chi (cdr x) (car x) empty-wrap mod))
+ (cons (cons er (source-wrap e w s mod))
+ (cdr body)))))))))))))))))
+
+ (define chi-local-syntax
+ (lambda (rec? e r w s mod k)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids #'(id ...)))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation #f "duplicate bound keyword" e)
+ (let ((labels (gen-labels ids)))
+ (let ((new-w (make-binding-wrap ids labels w)))
+ (k #'(e1 e2 ...)
+ (extend-env
+ labels
+ (let ((w (if rec? new-w w))
+ (trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding 'macro
+ (eval-local-transformer
+ (chi x trans-r w mod)
+ mod)))
+ #'(val ...)))
+ r)
+ new-w
+ s
+ mod))))))
+ (_ (syntax-violation #f "bad local syntax definition"
+ (source-wrap e w s mod))))))
+
+ (define eval-local-transformer
+ (lambda (expanded mod)
+ (let ((p (local-eval-hook expanded mod)))
+ (if (procedure? p)
+ (cons p (module-name (current-module)))
+ (syntax-violation #f "nonprocedure transformer" p)))))
+
+ (define chi-void
+ (lambda ()
+ (build-void no-source)))
+
+ (define ellipsis?
+ (lambda (x)
+ (and (nonsymbol-id? x)
+ (free-id=? x #'(... ...)))))
+
+ (define lambda-formals
+ (lambda (orig-args)
+ (define (req args rreq)
+ (syntax-case args ()
+ (()
+ (check (reverse rreq) #f))
+ ((a . b) (id? #'a)
+ (req #'b (cons #'a rreq)))
+ (r (id? #'r)
+ (check (reverse rreq) #'r))
+ (else
+ (syntax-violation 'lambda "invalid argument list" orig-args args))))
+ (define (check req rest)
+ (cond
+ ((distinct-bound-ids? (if rest (cons rest req) req))
+ (values req #f rest #f))
+ (else
+ (syntax-violation 'lambda "duplicate identifier in argument list"
+ orig-args))))
+ (req orig-args '())))
+
+ (define chi-simple-lambda
+ (lambda (e r w s mod req rest docstring body)
+ (let* ((ids (if rest (append req (list rest)) req))
+ (vars (map gen-var ids))
+ (labels (gen-labels ids)))
+ (build-simple-lambda
+ s
+ (map syntax->datum req) (and rest (syntax->datum rest)) vars
+ docstring
+ (chi-body body (source-wrap e w s mod)
+ (extend-var-env labels vars r)
+ (make-binding-wrap ids labels w)
+ mod)))))
+
+ (define lambda*-formals
+ (lambda (orig-args)
+ (define (req args rreq)
+ (syntax-case args ()
+ (()
+ (check (reverse rreq) '() #f '()))
+ ((a . b) (id? #'a)
+ (req #'b (cons #'a rreq)))
+ ((a . b) (eq? (syntax->datum #'a) #:optional)
+ (opt #'b (reverse rreq) '()))
+ ((a . b) (eq? (syntax->datum #'a) #:key)
+ (key #'b (reverse rreq) '() '()))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b (reverse rreq) '() '()))
+ (r (id? #'r)
+ (rest #'r (reverse rreq) '() '()))
+ (else
+ (syntax-violation 'lambda* "invalid argument list" orig-args args))))
+ (define (opt args req ropt)
+ (syntax-case args ()
+ (()
+ (check req (reverse ropt) #f '()))
+ ((a . b) (id? #'a)
+ (opt #'b req (cons #'(a #f) ropt)))
+ (((a init) . b) (id? #'a)
+ (opt #'b req (cons #'(a init) ropt)))
+ ((a . b) (eq? (syntax->datum #'a) #:key)
+ (key #'b req (reverse ropt) '()))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req (reverse ropt) '()))
+ (r (id? #'r)
+ (rest #'r req (reverse ropt) '()))
+ (else
+ (syntax-violation 'lambda* "invalid optional argument list"
+ orig-args args))))
+ (define (key args req opt rkey)
+ (syntax-case args ()
+ (()
+ (check req opt #f (cons #f (reverse rkey))))
+ ((a . b) (id? #'a)
+ (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+ (key #'b req opt (cons #'(k a #f) rkey))))
+ (((a init) . b) (id? #'a)
+ (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+ (key #'b req opt (cons #'(k a init) rkey))))
+ (((a init k) . b) (and (id? #'a)
+ (keyword? (syntax->datum #'k)))
+ (key #'b req opt (cons #'(k a init) rkey)))
+ ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (check req opt #f (cons #t (reverse rkey))))
+ ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (eq? (syntax->datum #'a) #:rest))
+ (rest #'b req opt (cons #t (reverse rkey))))
+ ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (id? #'r))
+ (rest #'r req opt (cons #t (reverse rkey))))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req opt (cons #f (reverse rkey))))
+ (r (id? #'r)
+ (rest #'r req opt (cons #f (reverse rkey))))
+ (else
+ (syntax-violation 'lambda* "invalid keyword argument list"
+ orig-args args))))
+ (define (rest args req opt kw)
+ (syntax-case args ()
+ (r (id? #'r)
+ (check req opt #'r kw))
+ (else
+ (syntax-violation 'lambda* "invalid rest argument"
+ orig-args args))))
+ (define (check req opt rest kw)
+ (cond
+ ((distinct-bound-ids?
+ (append req (map car opt) (if rest (list rest) '())
+ (if (pair? kw) (map cadr (cdr kw)) '())))
+ (values req opt rest kw))
+ (else
+ (syntax-violation 'lambda* "duplicate identifier in argument list"
+ orig-args))))
+ (req orig-args '())))
+
+ (define chi-lambda-case
+ (lambda (e r w s mod get-formals clauses)
+ (define (expand-req req opt rest kw body)
+ (let ((vars (map gen-var req))
+ (labels (gen-labels req)))
+ (let ((r* (extend-var-env labels vars r))
+ (w* (make-binding-wrap req labels w)))
+ (expand-opt (map syntax->datum req)
+ opt rest kw body (reverse vars) r* w* '() '()))))
+ (define (expand-opt req opt rest kw body vars r* w* out inits)
+ (cond
+ ((pair? opt)
+ (syntax-case (car opt) ()
+ ((id i)
+ (let* ((v (gen-var #'id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list #'id) l w*)))
+ (expand-opt req (cdr opt) rest kw body (cons v vars)
+ r** w** (cons (syntax->datum #'id) out)
+ (cons (chi #'i r* w* mod) inits))))))
+ (rest
+ (let* ((v (gen-var rest))
+ (l (gen-labels (list v)))
+ (r* (extend-var-env l (list v) r*))
+ (w* (make-binding-wrap (list rest) l w*)))
+ (expand-kw req (if (pair? out) (reverse out) #f)
+ (syntax->datum rest)
+ (if (pair? kw) (cdr kw) kw)
+ body (cons v vars) r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits)))
+ (else
+ (expand-kw req (if (pair? out) (reverse out) #f) #f
+ (if (pair? kw) (cdr kw) kw)
+ body vars r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits))))
+ (define (expand-kw req opt rest kw body vars r* w* aok out inits)
+ (cond
+ ((pair? kw)
+ (syntax-case (car kw) ()
+ ((k id i)
+ (let* ((v (gen-var #'id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list #'id) l w*)))
+ (expand-kw req opt rest (cdr kw) body (cons v vars)
+ r** w** aok
+ (cons (list (syntax->datum #'k)
+ (syntax->datum #'id)
+ v)
+ out)
+ (cons (chi #'i r* w* mod) inits))))))
+ (else
+ (expand-body req opt rest
+ (if (or aok (pair? out)) (cons aok (reverse out)) #f)
+ body (reverse vars) r* w* (reverse inits)))))
+ (define (expand-body req opt rest kw body vars r* w* inits)
+ (syntax-case body ()
+ ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+ (values (syntax->datum #'docstring) req opt rest kw inits vars
+ (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))
+ ((e1 e2 ...)
+ (values #f req opt rest kw inits vars
+ (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))))
+
+ (syntax-case clauses ()
+ (() (values #f #f))
+ (((args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values (lambda () (get-formals #'args))
+ (lambda (req opt rest kw)
+ (call-with-values (lambda ()
+ (expand-req req opt rest kw #'(e1 e2 ...)))
+ (lambda (docstring req opt rest kw inits vars body)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod get-formals
+ #'((args* e1* e2* ...) ...)))
+ (lambda (docstring* else*)
+ (values
+ (or docstring docstring*)
+ (build-lambda-case s req opt rest kw inits vars
+ body else*))))))))))))
+
+;;; data
+
+;;; strips syntax-objects down to top-wrap
+;;;
+;;; since only the head of a list is annotated by the reader, not each pair
+;;; in the spine, we also check for pairs whose cars are annotated in case
+;;; we've been passed the cdr of an annotated list
+
+ (define strip
+ (lambda (x w)
+ (if (top-marked? w)
+ x
+ (let f ((x x))
+ (cond
+ ((syntax-object? x)
+ (strip (syntax-object-expression x) (syntax-object-wrap x)))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x)))
+ x
+ (cons a d))))
+ ((vector? x)
+ (let ((old (vector->list x)))
+ (let ((new (map f old)))
+ (if (and-map* eq? old new) x (list->vector new)))))
+ (else x))))))
+
+;;; lexical variables
+
+ (define gen-var
+ (lambda (id)
+ (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (build-lexical-var no-source id))))
+
+ ;; appears to return a reversed list
+ (define lambda-var-list
+ (lambda (vars)
+ (let lvl ((vars vars) (ls '()) (w empty-wrap))
+ (cond
+ ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
+ ((id? vars) (cons (wrap vars w #f) ls))
+ ((null? vars) ls)
+ ((syntax-object? vars)
+ (lvl (syntax-object-expression vars)
+ ls
+ (join-wraps w (syntax-object-wrap vars))))
+ ; include anything else to be caught by subsequent error
+ ; checking
+ (else (cons vars ls))))))
+
+;;; core transformers
+
+ (global-extend 'local-syntax 'letrec-syntax #t)
+ (global-extend 'local-syntax 'let-syntax #f)
+
+ (global-extend 'core 'fluid-let-syntax
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? #'(var ...))
+ (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
+ (for-each
+ (lambda (id n)
+ (case (binding-type (lookup n r mod))
+ ((displaced-lexical)
+ (syntax-violation 'fluid-let-syntax
+ "identifier out of context"
+ e
+ (source-wrap id w s mod)))))
+ #'(var ...)
+ names)
+ (chi-body
+ #'(e1 e2 ...)
+ (source-wrap e w s mod)
+ (extend-env
+ names
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding 'macro
+ (eval-local-transformer (chi x trans-r w mod)
+ mod)))
+ #'(val ...)))
+ r)
+ w
+ mod)))
+ (_ (syntax-violation 'fluid-let-syntax "bad syntax"
+ (source-wrap e w s mod))))))
+
+ (global-extend 'core 'quote
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ e) (build-data s (strip #'e w)))
+ (_ (syntax-violation 'quote "bad syntax"
+ (source-wrap e w s mod))))))
+
+ (global-extend 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
+ (let ((label (id-var-name e empty-wrap)))
+ (let ((b (lookup label r mod)))
+ (if (eq? (binding-type b) 'syntax)
+ (call-with-values
+ (lambda ()
+ (let ((var.lev (binding-value b)))
+ (gen-ref src (car var.lev) (cdr var.lev) maps)))
+ (lambda (var maps) (values `(ref ,var) maps)))
+ (if (ellipsis? e)
+ (syntax-violation 'syntax "misplaced ellipsis" src)
+ (values `(quote ,e) maps)))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? #'dots)
+ (gen-syntax src #'e r maps (lambda (x) #f) mod))
+ ((x dots . y)
+ ; this could be about a dozen lines of code, except that we
+ ; choose to handle #'(x ... ...) forms
+ (ellipsis? #'dots)
+ (let f ((y #'y)
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'x r
+ (cons '() maps) ellipsis? mod))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
+ (values (gen-map x (car maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? #'dots)
+ (f #'y
+ (lambda (maps)
+ (call-with-values
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis" src)
+ (values (gen-mappend x (car maps))
+ (cdr maps))))))))
+ (_ (call-with-values
+ (lambda () (gen-syntax src y r maps ellipsis? mod))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps)
+ (values (gen-append x y) maps)))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (gen-syntax src #'x r maps ellipsis? mod))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src #'y r maps ellipsis? mod))
+ (lambda (y maps) (values (gen-cons x y) maps))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-violation 'syntax "missing ellipsis" src)
+ (call-with-values
+ (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var inner-var)
+ (car maps))
+ outer-maps)))))))))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ; identity map equivalence:
+ ; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((and-map
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ; eta map equivalence:
+ ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ (define gen-cons
+ (lambda (x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y)))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-vector
+ (lambda (x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x)))))
+
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda)
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr x) #f (cadr x) #f (regen (caddr x)))
+ (error "how did we get here" x)))
+ (else (build-application no-source
+ (build-primref no-source (car x))
+ (map regen (cdr x)))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ x)
+ (call-with-values
+ (lambda () (gen-syntax e #'x r '() ellipsis? mod))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
+
+ (global-extend 'core 'lambda
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ args docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+ (call-with-values (lambda () (lambda-formals #'args))
+ (lambda (req opt rest kw)
+ (chi-simple-lambda e r w s mod req rest (syntax->datum #'docstring)
+ #'(e1 e2 ...)))))
+ ((_ args e1 e2 ...)
+ (call-with-values (lambda () (lambda-formals #'args))
+ (lambda (req opt rest kw)
+ (chi-simple-lambda e r w s mod req rest #f #'(e1 e2 ...)))))
+ (_ (syntax-violation 'lambda "bad lambda" e)))))
+
+ (global-extend 'core 'lambda*
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ args e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda*-formals #'((args e1 e2 ...))))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'lambda "bad lambda*" e)))))
+
+ (global-extend 'core 'case-lambda
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda-formals
+ #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
+
+ (global-extend 'core 'case-lambda*
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda*-formals
+ #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+
+ (global-extend 'core 'let
+ (let ()
+ (define (chi-let e r w s mod constructor ids vals exps)
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation 'let "duplicate bound variable" e)
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((nw (make-binding-wrap ids labels w))
+ (nr (extend-var-env labels new-vars r)))
+ (constructor s
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (chi x r w mod)) vals)
+ (chi-body exps (source-wrap e nw s mod)
+ nr nw mod))))))
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (and-map id? #'(id ...))
+ (chi-let e r w s mod
+ build-let
+ #'(id ...)
+ #'(val ...)
+ #'(e1 e2 ...)))
+ ((_ f ((id val) ...) e1 e2 ...)
+ (and (id? #'f) (and-map id? #'(id ...)))
+ (chi-let e r w s mod
+ build-named-let
+ #'(f id ...)
+ #'(val ...)
+ #'(e1 e2 ...)))
+ (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
+
+
+ (global-extend 'core 'letrec
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (and-map id? #'(id ...))
+ (let ((ids #'(id ...)))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation 'letrec "duplicate bound variable" e)
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((w (make-binding-wrap ids labels w))
+ (r (extend-var-env labels new-vars r)))
+ (build-letrec s
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (chi x r w mod)) #'(val ...))
+ (chi-body #'(e1 e2 ...)
+ (source-wrap e w s mod) r w mod)))))))
+ (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
+
+
+ (global-extend 'core 'set!
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ id val)
+ (id? #'id)
+ (let ((val (chi #'val r w mod))
+ (n (id-var-name #'id w)))
+ (let ((b (lookup n r mod)))
+ (case (binding-type b)
+ ((lexical)
+ (build-lexical-assignment s
+ (syntax->datum #'id)
+ (binding-value b)
+ val))
+ ((global) (build-global-assignment s n val mod))
+ ((displaced-lexical)
+ (syntax-violation 'set! "identifier out of context"
+ (wrap #'id w mod)))
+ (else (syntax-violation 'set! "bad set!"
+ (source-wrap e w s mod)))))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
+ (lambda (type value ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (chi #'val r w mod)))
+ (call-with-values (lambda () (value #'(head tail ...)))
+ (lambda (id mod)
+ (build-global-assignment s id val mod)))))
+ (else
+ (build-application s
+ (chi #'(setter head) r w mod)
+ (map (lambda (e) (chi e r w mod))
+ #'(tail ... val))))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+
+ (global-extend 'module-ref '@
+ (lambda (e)
+ (syntax-case e ()
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ (values (syntax->datum #'id)
+ (syntax->datum
+ #'(public mod ...)))))))
+
+ (global-extend 'module-ref '@@
+ (lambda (e)
+ (syntax-case e ()
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ (values (syntax->datum #'id)
+ (syntax->datum
+ #'(private mod ...)))))))
+
+ (global-extend 'core 'if
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional
+ s
+ (chi #'test r w mod)
+ (chi #'then r w mod)
+ (build-void no-source)))
+ ((_ test then else)
+ (build-conditional
+ s
+ (chi #'test r w mod)
+ (chi #'then r w mod)
+ (chi #'else r w mod))))))
+
+ (global-extend 'begin 'begin '())
+
+ (global-extend 'define 'define '())
+
+ (global-extend 'define-syntax 'define-syntax '())
+
+ (global-extend 'eval-when 'eval-when '())
+
+ (global-extend 'core 'syntax-case
+ (let ()
+ (define convert-pattern
+ ; accepts pattern & keys
+ ; returns $sc-dispatch pattern & ids
+ (lambda (pattern keys)
+ (let cvt ((p pattern) (n 0) (ids '()))
+ (if (id? p)
+ (if (bound-id-member? p keys)
+ (values (vector 'free-id p) ids)
+ (values 'any (cons (cons p n) ids)))
+ (syntax-case p ()
+ ((x dots)
+ (ellipsis? #'dots)
+ (call-with-values
+ (lambda () (cvt #'x (fx+ n 1) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any (vector 'each p))
+ ids))))
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt #'y n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt #'x n ids))
+ (lambda (x ids)
+ (values (cons x y) ids))))))
+ (() (values '() ids))
+ (#(x ...)
+ (call-with-values
+ (lambda () (cvt #'(x ...) n ids))
+ (lambda (p ids) (values (vector 'vector p) ids))))
+ (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
+
+ (define build-dispatch-call
+ (lambda (pvars exp y r mod)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (build-application no-source
+ (build-primref no-source 'apply)
+ (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars #f
+ (chi exp
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)
+ mod))
+ y))))))
+
+ (define gen-clause
+ (lambda (x keys clauses r pat fender exp mod)
+ (call-with-values
+ (lambda () (convert-pattern pat keys))
+ (lambda (p pvars)
+ (cond
+ ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-violation 'syntax-case "duplicate pattern variable" pat))
+ ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (syntax-violation 'syntax-case "misplaced ellipsis" pat))
+ (else
+ (let ((y (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable y
+ (build-application no-source
+ (build-simple-lambda no-source (list 'tmp) #f (list y) #f
+ (let ((y (build-lexical-reference 'value no-source
+ 'tmp y)))
+ (build-conditional no-source
+ (syntax-case fender ()
+ (#t y)
+ (_ (build-conditional no-source
+ y
+ (build-dispatch-call pvars fender y r mod)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r mod)
+ (gen-syntax-case x keys clauses r mod))))
+ (list (if (eq? p 'any)
+ (build-application no-source
+ (build-primref no-source 'list)
+ (list x))
+ (build-application no-source
+ (build-primref no-source '$sc-dispatch)
+ (list x (build-data no-source p)))))))))))))
+
+ (define gen-syntax-case
+ (lambda (x keys clauses r mod)
+ (if (null? clauses)
+ (build-application no-source
+ (build-primref no-source 'syntax-violation)
+ (list (build-data no-source #f)
+ (build-data no-source
+ "source expression failed to match any pattern")
+ x))
+ (syntax-case (car clauses) ()
+ ((pat exp)
+ (if (and (id? #'pat)
+ (and-map (lambda (x) (not (free-id=? #'pat x)))
+ (cons #'(... ...) keys)))
+ (let ((labels (list (gen-label)))
+ (var (gen-var #'pat)))
+ (build-application no-source
+ (build-simple-lambda
+ no-source (list (syntax->datum #'pat)) #f (list var)
+ #f
+ (chi #'exp
+ (extend-env labels
+ (list (make-binding 'syntax `(,var . 0)))
+ r)
+ (make-binding-wrap #'(pat)
+ labels empty-wrap)
+ mod))
+ (list x)))
+ (gen-clause x keys (cdr clauses) r
+ #'pat #t #'exp mod)))
+ ((pat fender exp)
+ (gen-clause x keys (cdr clauses) r
+ #'pat #'fender #'exp mod))
+ (_ (syntax-violation 'syntax-case "invalid clause"
+ (car clauses)))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ val (key ...) m ...)
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
+ #'(key ...))
+ (let ((x (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable x
+ (build-application s
+ (build-simple-lambda no-source (list 'tmp) #f (list x) #f
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
+ #'(key ...) #'(m ...)
+ r
+ mod))
+ (list (chi #'val r empty-wrap mod))))
+ (syntax-violation 'syntax-case "invalid literals list" e))))))))
+
+;;; The portable sc-expand seeds chi-top's mode m with 'e (for
+;;; evaluating) and esew (which stands for "eval syntax expanders
+;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
+;;; if we are compiling a file, and esew is set to
+;;; (eval-syntactic-expanders-when), which defaults to the list
+;;; '(compile load eval). This means that, by default, top-level
+;;; syntactic definitions are evaluated immediately after they are
+;;; expanded, and the expanded definitions are also residualized into
+;;; the object file if we are compiling a file.
+ (set! sc-expand
+ (lambda (x . rest)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (let ((m (if (null? rest) 'e (car rest)))
+ (esew (if (or (null? rest) (null? (cdr rest)))
+ '(eval)
+ (cadr rest))))
+ (with-fluid* *mode* m
+ (lambda ()
+ (chi-top x null-env top-wrap m esew
+ (cons 'hygiene (module-name (current-module))))))))))
+
+ (set! identifier?
+ (lambda (x)
+ (nonsymbol-id? x)))
+
+ (set! datum->syntax
+ (lambda (id datum)
+ (make-syntax-object datum (syntax-object-wrap id) #f)))
+
+ (set! syntax->datum
+ ; accepts any object, since syntax objects may consist partially
+ ; or entirely of unwrapped, nonsymbolic data
+ (lambda (x)
+ (strip x empty-wrap)))
+
+ (set! generate-temporaries
+ (lambda (ls)
+ (arg-check list? ls 'generate-temporaries)
+ (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
+
+ (set! free-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'free-identifier=?)
+ (arg-check nonsymbol-id? y 'free-identifier=?)
+ (free-id=? x y)))
+
+ (set! bound-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'bound-identifier=?)
+ (arg-check nonsymbol-id? y 'bound-identifier=?)
+ (bound-id=? x y)))
+
+ (set! syntax-violation
+ (lambda (who message form . subform)
+ (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+ who 'syntax-violation)
+ (arg-check string? message 'syntax-violation)
+ (scm-error 'syntax-error 'sc-expand
+ (string-append
+ (if who "~a: " "")
+ "~a "
+ (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
+ (let ((tail (cons message
+ (map (lambda (x) (strip x empty-wrap))
+ (append subform (list form))))))
+ (if who (cons who tail) tail))
+ #f)))
+
+;;; $sc-dispatch expects an expression and a pattern. If the expression
+;;; matches the pattern a list of the matching expressions for each
+;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
+;;; not work on r4rs implementations that violate the ieee requirement
+;;; that #f and () be distinct.)
+
+;;; The expression is matched with the pattern as follows:
+
+;;; pattern: matches:
+;;; () empty list
+;;; any anything
+;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
+;;; each-any (any*)
+;;; #(free-id <key>) <key> with free-identifier=?
+;;; #(each <pattern>) (<pattern>*)
+;;; #(vector <pattern>) (list->vector <pattern>)
+;;; #(atom <object>) <object> with "equal?"
+
+;;; Vector cops out to pair under assumption that vectors are rare. If
+;;; not, should convert to:
+;;; #(vector <pattern>*) #(<pattern>*)
+
+ (let ()
+
+ (define match-each
+ (lambda (e p w mod)
+ (cond
+ ((pair? e)
+ (let ((first (match (car e) p w '() mod)))
+ (and first
+ (let ((rest (match-each (cdr e) p w mod)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ (syntax-object-module e)))
+ (else #f))))
+
+ (define match-each-any
+ (lambda (e w mod)
+ (cond
+ ((pair? e)
+ (let ((l (match-each-any (cdr e) w mod)))
+ (and l (cons (wrap (car e) w mod) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))
+ mod))
+ (else #f))))
+
+ (define match-empty
+ (lambda (p r)
+ (cond
+ ((null? p) r)
+ ((eq? p 'any) (cons '() r))
+ ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+ ((eq? p 'each-any) (cons '() r))
+ (else
+ (case (vector-ref p 0)
+ ((each) (match-empty (vector-ref p 1) r))
+ ((free-id atom) r)
+ ((vector) (match-empty (vector-ref p 1) r)))))))
+
+ (define match*
+ (lambda (e p w r mod)
+ (cond
+ ((null? p) (and (null? e) r))
+ ((pair? p)
+ (and (pair? e) (match (car e) (car p) w
+ (match (cdr e) (cdr p) w r mod)
+ mod)))
+ ((eq? p 'each-any)
+ (let ((l (match-each-any e w mod))) (and l (cons l r))))
+ (else
+ (case (vector-ref p 0)
+ ((each)
+ (if (null? e)
+ (match-empty (vector-ref p 1) r)
+ (let ((l (match-each e (vector-ref p 1) w mod)))
+ (and l
+ (let collect ((l l))
+ (if (null? (car l))
+ r
+ (cons (map car l) (collect (map cdr l)))))))))
+ ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
+ ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
+ ((vector)
+ (and (vector? e)
+ (match (vector->list e) (vector-ref p 1) w r mod))))))))
+
+ (define match
+ (lambda (e p w r mod)
+ (cond
+ ((not r) #f)
+ ((eq? p 'any) (cons (wrap e w mod) r))
+ ((syntax-object? e)
+ (match*
+ (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r
+ (syntax-object-module e)))
+ (else (match* e p w r mod)))))
+
+ (set! $sc-dispatch
+ (lambda (e p)
+ (cond
+ ((eq? p 'any) (list e))
+ ((syntax-object? e)
+ (match* (syntax-object-expression e)
+ p (syntax-object-wrap e) '() (syntax-object-module e)))
+ (else (match* e p empty-wrap '() #f)))))
+
+ ))
+)
+
+(define-syntax with-syntax
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () e1 e2 ...)
+ #'(begin e1 e2 ...))
+ ((_ ((out in)) e1 e2 ...)
+ #'(syntax-case in () (out (begin e1 e2 ...))))
+ ((_ ((out in) ...) e1 e2 ...)
+ #'(syntax-case (list in ...) ()
+ ((out ...) (begin e1 e2 ...)))))))
+
+(define-syntax syntax-rules
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k ...) ((keyword . pattern) template) ...)
+ #'(lambda (x)
+ (syntax-case x (k ...)
+ ((dummy . pattern) #'template)
+ ...))))))
+
+(define-syntax let*
+ (lambda (x)
+ (syntax-case x ()
+ ((let* ((x v) ...) e1 e2 ...)
+ (and-map identifier? #'(x ...))
+ (let f ((bindings #'((x v) ...)))
+ (if (null? bindings)
+ #'(let () e1 e2 ...)
+ (with-syntax ((body (f (cdr bindings)))
+ (binding (car bindings)))
+ #'(let (binding) body))))))))
+
+(define-syntax do
+ (lambda (orig-x)
+ (syntax-case orig-x ()
+ ((_ ((var init . step) ...) (e0 e1 ...) c ...)
+ (with-syntax (((step ...)
+ (map (lambda (v s)
+ (syntax-case s ()
+ (() v)
+ ((e) #'e)
+ (_ (syntax-violation
+ 'do "bad step expression"
+ orig-x s))))
+ #'(var ...)
+ #'(step ...))))
+ (syntax-case #'(e1 ...) ()
+ (() #'(let doloop ((var init) ...)
+ (if (not e0)
+ (begin c ... (doloop step ...)))))
+ ((e1 e2 ...)
+ #'(let doloop ((var init) ...)
+ (if e0
+ (begin e1 e2 ...)
+ (begin c ... (doloop step ...)))))))))))
+
+(define-syntax quasiquote
+ (letrec
+ ((quasicons
+ (lambda (x y)
+ (with-syntax ((x x) (y y))
+ (syntax-case #'y (quote list)
+ ((quote dy)
+ (syntax-case #'x (quote)
+ ((quote dx) #'(quote (dx . dy)))
+ (_ (if (null? #'dy)
+ #'(list x)
+ #'(cons x y)))))
+ ((list . stuff) #'(list x . stuff))
+ (else #'(cons x y))))))
+ (quasiappend
+ (lambda (x y)
+ (with-syntax ((x x) (y y))
+ (syntax-case #'y (quote)
+ ((quote ()) #'x)
+ (_ #'(append x y))))))
+ (quasivector
+ (lambda (x)
+ (with-syntax ((x x))
+ (syntax-case #'x (quote list)
+ ((quote (x ...)) #'(quote #(x ...)))
+ ((list x ...) #'(vector x ...))
+ (_ #'(list->vector x))))))
+ (quasi
+ (lambda (p lev)
+ (syntax-case p (unquote unquote-splicing quasiquote)
+ ((unquote p)
+ (if (= lev 0)
+ #'p
+ (quasicons #'(quote unquote)
+ (quasi #'(p) (- lev 1)))))
+ ((unquote . args)
+ (= lev 0)
+ (syntax-violation 'unquote
+ "unquote takes exactly one argument"
+ p #'(unquote . args)))
+ (((unquote-splicing p) . q)
+ (if (= lev 0)
+ (quasiappend #'p (quasi #'q lev))
+ (quasicons (quasicons #'(quote unquote-splicing)
+ (quasi #'(p) (- lev 1)))
+ (quasi #'q lev))))
+ (((unquote-splicing . args) . q)
+ (= lev 0)
+ (syntax-violation 'unquote-splicing
+ "unquote-splicing takes exactly one argument"
+ p #'(unquote-splicing . args)))
+ ((quasiquote p)
+ (quasicons #'(quote quasiquote)
+ (quasi #'(p) (+ lev 1))))
+ ((p . q)
+ (quasicons (quasi #'p lev) (quasi #'q lev)))
+ (#(x ...) (quasivector (quasi #'(x ...) lev)))
+ (p #'(quote p))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e) (quasi #'e 0))))))
+
+(define-syntax include
+ (lambda (x)
+ (define read-file
+ (lambda (fn k)
+ (let ((p (open-input-file fn)))
+ (let f ((x (read p)))
+ (if (eof-object? x)
+ (begin (close-input-port p) '())
+ (cons (datum->syntax k x)
+ (f (read p))))))))
+ (syntax-case x ()
+ ((k filename)
+ (let ((fn (syntax->datum #'filename)))
+ (with-syntax (((exp ...) (read-file fn #'k)))
+ #'(begin exp ...)))))))
+
+(define-syntax include-from-path
+ (lambda (x)
+ (syntax-case x ()
+ ((k filename)
+ (let ((fn (syntax->datum #'filename)))
+ (with-syntax ((fn (or (%search-load-path fn)
+ (syntax-violation 'include-from-path
+ "file not found in path"
+ x #'filename))))
+ #'(include fn)))))))
+
+(define-syntax unquote
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax-violation 'unquote
+ "expression not valid outside of quasiquote"
+ x)))))
+
+(define-syntax unquote-splicing
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax-violation 'unquote-splicing
+ "expression not valid outside of quasiquote"
+ x)))))
+
+(define-syntax case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e m1 m2 ...)
+ (with-syntax
+ ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
+ (if (null? clauses)
+ (syntax-case clause (else)
+ ((else e1 e2 ...) #'(begin e1 e2 ...))
+ (((k ...) e1 e2 ...)
+ #'(if (memv t '(k ...)) (begin e1 e2 ...)))
+ (_ (syntax-violation 'case "bad clause" x clause)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else)
+ (((k ...) e1 e2 ...)
+ #'(if (memv t '(k ...))
+ (begin e1 e2 ...)
+ rest))
+ (_ (syntax-violation 'case "bad clause" x
+ clause))))))))
+ #'(let ((t e)) body))))))
+
+(define-syntax identifier-syntax
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ #'(lambda (x)
+ (syntax-case x ()
+ (id
+ (identifier? #'id)
+ #'e)
+ ((_ x (... ...))
+ #'(e x (... ...)))))))))
+
+(define-syntax define*
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (define id (lambda* args b0 b1 ...)))))
--- /dev/null
+;; Quasisyntax in terms of syntax-case.
+;;
+;; Code taken from
+;; <http://www.het.brown.edu/people/andre/macros/index.html>;
+;; Copyright (c) 2006 Andre van Tonder. All Rights Reserved.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;=========================================================
+;;
+;; To make nested unquote-splicing behave in a useful way,
+;; the R5RS-compatible extension of quasiquote in appendix B
+;; of the following paper is here ported to quasisyntax:
+;;
+;; Alan Bawden - Quasiquotation in Lisp
+;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html
+;;
+;; The algorithm converts a quasisyntax expression to an
+;; equivalent with-syntax expression.
+;; For example:
+;;
+;; (quasisyntax (set! #,a #,b))
+;; ==> (with-syntax ((t0 a)
+;; (t1 b))
+;; (syntax (set! t0 t1)))
+;;
+;; (quasisyntax (list #,@args))
+;; ==> (with-syntax (((t ...) args))
+;; (syntax (list t ...)))
+;;
+;; Note that quasisyntax is expanded first, before any
+;; ellipses act. For example:
+;;
+;; (quasisyntax (f ((b #,a) ...))
+;; ==> (with-syntax ((t a))
+;; (syntax (f ((b t) ...))))
+;;
+;; so that
+;;
+;; (let-syntax ((test-ellipses-over-unsyntax
+;; (lambda (e)
+;; (let ((a (syntax a)))
+;; (with-syntax (((b ...) (syntax (1 2 3))))
+;; (quasisyntax
+;; (quote ((b #,a) ...))))))))
+;; (test-ellipses-over-unsyntax))
+;;
+;; ==> ((1 a) (2 a) (3 a))
+(define-syntax quasisyntax
+ (lambda (e)
+
+ ;; Expand returns a list of the form
+ ;; [template[t/e, ...] (replacement ...)]
+ ;; Here template[t/e ...] denotes the original template
+ ;; with unquoted expressions e replaced by fresh
+ ;; variables t, followed by the appropriate ellipses
+ ;; if e is also spliced.
+ ;; The second part of the return value is the list of
+ ;; replacements, each of the form (t e) if e is just
+ ;; unquoted, or ((t ...) e) if e is also spliced.
+ ;; This will be the list of bindings of the resulting
+ ;; with-syntax expression.
+
+ (define (expand x level)
+ (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
+ ((quasisyntax e)
+ (with-syntax (((k _) x) ;; original identifier must be copied
+ ((e* reps) (expand (syntax e) (+ level 1))))
+ (syntax ((k e*) reps))))
+ ((unsyntax e)
+ (= level 0)
+ (with-syntax (((t) (generate-temporaries '(t))))
+ (syntax (t ((t e))))))
+ (((unsyntax e ...) . r)
+ (= level 0)
+ (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
+ ((t ...) (generate-temporaries (syntax (e ...)))))
+ (syntax ((t ... . r*)
+ ((t e) ... rep ...)))))
+ (((unsyntax-splicing e ...) . r)
+ (= level 0)
+ (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
+ ((t ...) (generate-temporaries (syntax (e ...)))))
+ (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
+ (syntax ((t ... ... . r*)
+ (((t ...) e) ... rep ...))))))
+ ((k . r)
+ (and (> level 0)
+ (identifier? (syntax k))
+ (or (free-identifier=? (syntax k) (syntax unsyntax))
+ (free-identifier=? (syntax k) (syntax unsyntax-splicing))))
+ (with-syntax (((r* reps) (expand (syntax r) (- level 1))))
+ (syntax ((k . r*) reps))))
+ ((h . t)
+ (with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
+ ((t* (rep2 ...)) (expand (syntax t) level)))
+ (syntax ((h* . t*)
+ (rep1 ... rep2 ...)))))
+ (#(e ...)
+ (with-syntax ((((e* ...) reps)
+ (expand (vector->list (syntax #(e ...))) level)))
+ (syntax (#(e* ...) reps))))
+ (other
+ (syntax (other ())))))
+
+ (syntax-case e ()
+ ((_ template)
+ (with-syntax (((template* replacements) (expand (syntax template) 0)))
+ (syntax
+ (with-syntax replacements (syntax template*))))))))
+
+(define-syntax unsyntax
+ (lambda (e)
+ (syntax-violation 'unsyntax "Invalid expression" e)))
+
+(define-syntax unsyntax-splicing
+ (lambda (e)
+ (syntax-violation 'unsyntax "Invalid expression" e)))
-;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009 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
(= (length name) 2)
(eq? (car name) 'unquote))
(let ((doc (try-value-help (cadr name)
- (local-eval (cadr name) env))))
+ (module-ref (current-module)
+ (cadr name)))))
(cond ((not doc) (not-found 'documentation (cadr name)))
((eq? doc #t)) ;; pass
(else (write-line doc)))))
(cons (list module
name
(try-value-help name object)
- (cond ((closure? object)
+ (cond ((procedure? object)
"a procedure")
- ((procedure? object)
- "a primitive procedure")
(else
"an object")))
data))
(= (car arity) 1)
(<= (cadr arity) 1))
(display " argument")
- (display " arguments"))
- (if (closure? obj)
- (let ((formals (cadr (procedure-source obj))))
- (cond
- ((pair? formals)
- (display ": ")
- (display-arg-list formals))
- (else
- (display " in `")
- (display formals)
- (display #\'))))))))
+ (display " arguments")))))
(display ".\n"))
assembly-pack assembly-unpack
object->assembly assembly->object))
-;; nargs, nrest, nlocs, len, metalen, padding
-(define *program-header-len* (+ 1 1 2 4 4 4))
+;; len, metalen
+(define *program-header-len* (+ 4 4))
;; lengths are encoded in 3 bytes
(define *len-len* 3)
(+ 1 *len-len* (string-length str)))
((load-array ,bv)
(+ 1 *len-len* (bytevector-length bv)))
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+ ((load-program ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
'(nop)))
(define (align-block addr)
- (code-alignment addr *block-alignment* 0))
+ '())
(define (align-code code addr alignment header-len)
`(,@(code-alignment addr alignment header-len)
(define (write-uint16-le x)
(write-byte (logand x 255))
(write-byte (logand (ash x -8) 255)))
+ (define (write-uint24-be x)
+ (write-byte (logand (ash x -16) 255))
+ (write-byte (logand (ash x -8) 255))
+ (write-byte (logand x 255)))
(define (write-uint32-be x)
(write-byte (logand (ash x -24) 255))
(write-byte (logand (ash x -16) 255))
(define (write-loader str)
(write-loader-len (string-length str))
(write-string str))
- (define (write-sized-loader str)
- (let ((len (string-length str))
- (wid (string-bytes-per-char str)))
- (write-loader-len len)
- (write-byte wid)
- (if (= wid 4)
- (write-wide-string str)
- (write-string str))))
(define (write-bytevector bv)
(write-loader-len (bytevector-length bv))
;; Ew!
(for-each write-byte (bytevector->u8-list bv)))
(define (write-break label)
- (let ((offset (- (assq-ref labels label)
- (logand (+ (get-addr) 2) (lognot #x7)))))
- (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
- ((>= offset (ash 1 18)) (error "jump too far forward" offset))
- ((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
- (else (write-uint16-be (ash offset -3))))))
+ (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
+ (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
+ ((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
+ (else (write-uint24-be offset)))))
(let ((inst (car asm))
(args (cdr asm))
(len (instruction-length inst)))
(write-byte opcode)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
- (write-byte nargs)
- (write-byte nrest)
- (write-uint16 nlocs)
+ ((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
- (write-uint32 0) ; padding
(letrec ((i 0)
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
(get-addr (lambda () i)))
((br-if-not-eq ,l) (write-break l))
((br-if-null ,l) (write-break l))
((br-if-not-null ,l) (write-break l))
+ ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
+ ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
+ ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((mv-call ,n ,l) (write-byte n) (write-break l))
(else
(cond
(define (br-instruction? x)
(memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null br-if-not-null)))
+(define (br-nargs-instruction? x)
+ (memq x '(br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)))
-(define (bytes->s16 a b)
- (let ((x (+ (ash a 8) b)))
- (if (zero? (logand (ash 1 15) x))
+(define (bytes->s24 a b c)
+ (let ((x (+ (ash a 16) (ash b 8) c)))
+ (if (zero? (logand (ash 1 23) x))
x
- (- x (ash 1 16)))))
+ (- x (ash 1 24)))))
;; FIXME: this is a little-endian disassembly!!!
(define (decode-load-program pop)
- (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
- (nlocs (+ nlocs0 (ash nlocs1 8)))
- (a (pop)) (b (pop)) (c (pop)) (d (pop))
+ (let* ((a (pop)) (b (pop)) (c (pop)) (d (pop))
(e (pop)) (f (pop)) (g (pop)) (h (pop))
(len (+ a (ash b 8) (ash c 16) (ash d 24)))
(metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
- (totlen (+ len metalen))
- (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop))
(labels '())
(i 0))
- (define (ensure-label rel1 rel2)
- (let ((where (+ (logand i (lognot #x7))
- (* (bytes->s16 rel1 rel2) 8))))
+ (define (ensure-label rel1 rel2 rel3)
+ (let ((where (+ i (bytes->s24 rel1 rel2 rel3))))
(or (assv-ref labels where)
(begin
(let ((l (gensym ":L")))
(cond ((> i len)
(error "error decoding program -- read too many bytes" out))
((= i len)
- `(load-program ,nargs ,nrest ,nlocs
- ,(map (lambda (x) (cons (cdr x) (car x)))
+ `(load-program ,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels))
,len
,(if (zero? metalen) #f (decode-load-program pop))
(else
(let ((exp (decode-bytecode sub-pop)))
(pmatch exp
- ((,br ,rel1 ,rel2) (guard (br-instruction? br))
- (lp (cons `(,br ,(ensure-label rel1 rel2)) out)))
- ((mv-call ,n ,rel1 ,rel2)
- (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2)) out)))
+ ((,br ,rel1 ,rel2 ,rel3) (guard (br-instruction? br))
+ (lp (cons `(,br ,(ensure-label rel1 rel2 rel3)) out)))
+ ((,br ,hi ,lo ,rel1 ,rel2 ,rel3) (guard (br-nargs-instruction? br))
+ (lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3)) out)))
+ ((mv-call ,n ,rel1 ,rel2 ,rel3)
+ (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
(else
(lp (cons exp out))))))))))
(let lp ((i 0))
(if (= i len)
`(,inst ,(if (eq? inst 'load-wide-string)
- (utf32->string seq)
+ (utf32->string seq (native-endianness))
seq))
(begin
(sequence-set! seq i (pop))
(define (disassemble-load-program asm env)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+ ((load-program ,labels ,len ,meta . ,code)
(let ((objs (and env (assq-ref env 'objects)))
(free-vars (and env (assq-ref env 'free-vars)))
(meta (and env (assq-ref env 'meta)))
(lp (+ pos (byte-length asm)) (cdr code) programs))
(else
(print-info pos asm
- (code-annotation end asm objs nargs blocs
+ ;; FIXME: code-annotation for whether it's
+ ;; an arg or not, currently passing nargs=-1
+ (code-annotation end asm objs -1 blocs
labels)
(and=> (and srcs (assq end srcs)) source->string))
(lp (+ pos (byte-length asm)) (cdr code) programs)))))))
(define (disassemble-free-vars free-vars)
(display "Free variables:\n\n")
- (let ((i 0))
+ (let lp ((i 0))
(cond ((< i (vector-length free-vars))
(print-info i (vector-ref free-vars i) #f #f)
(lp (1+ i))))))
(define *uninteresting-props* '(name))
(define (disassemble-meta meta)
- (let ((sources (cadr meta))
- (props (filter (lambda (x)
+ (let ((props (filter (lambda (x)
(not (memq (car x) *uninteresting-props*)))
(cddr meta))))
(unless (null? props)
(list "~a element~:p" (apply make-int16 args)))
((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
(list "-> ~A" (assq-ref labels (car args))))
+ ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
+ (list "-> ~A" (assq-ref labels (caddr args))))
((object-ref)
(and objs (list "~s" (vector-ref objs (car args)))))
((local-ref local-boxed-ref local-set local-boxed-set)
;;; Guile Virtual Machine Assembly
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 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
(define-language assembly
#:title "Guile Virtual Machine Assembly Language"
#:version "2.0"
- #:reader read
+ #:reader (lambda (port env) (read port))
#:printer write
#:parser read ;; fixme: make a verifier?
#:compilers `((bytecode . ,compile-bytecode))
((<bf-loop> . ,body)
(let ((iterate (gensym)))
(emit `(letrec (iterate) (,iterate)
- ((lambda () ()
- (if (apply (primitive =)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const 0))
- (void)
- (begin ,(compile-body body)
- (apply (lexical ,iterate))))))
+ ((lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
+ (if (apply (primitive =)
+ (apply (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const 0))
+ (void)
+ (begin ,(compile-body body)
+ (apply (lexical ,iterate)))))
+ #f)))
(apply (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))
(define (read-brainfuck p)
(let iterate ((parsed '()))
(let ((chr (read-char p)))
- (if (or (eof-object? chr) (eq? #\] chr))
- (reverse-without-nops parsed)
- (iterate (cons (process-input-char chr p) parsed))))))
+ (cond
+ ((eof-object? chr)
+ (let ((parsed (reverse-without-nops parsed)))
+ (if (null? parsed)
+ chr ;; pass on the EOF object
+ parsed)))
+ ((eqv? chr #\])
+ (reverse-without-nops parsed))
+ (else
+ (iterate (cons (process-input-char chr p) parsed)))))))
; This routine processes a single character of input and builds the
(define-language brainfuck
#:title "Guile Brainfuck"
#:version "1.0"
- #:reader (lambda () (read-brainfuck (current-input-port)))
+ #:reader (lambda (port env) (read-brainfuck port))
#:compilers `((tree-il . ,compile-tree-il)
(scheme . ,compile-scheme))
#:printer write
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 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
(define-language bytecode
#:title "Guile Bytecode Vectors"
#:version "0.3"
- #:reader read
+ #:reader (lambda (port env) (read port))
#:printer write
#:compilers `((objcode . ,compile-objcode))
#:decompilers `((objcode . ,decompile-objcode))
o))))
(define (object->value/string o)
- (let ((v (object->string o #f)))
- (if (is-a? x <js-object>)
- (object->number o #t)
- x)))
-
+ (if (is-a? o <js-object>)
+ (object->number o #t)
+ o))
+
(define (object->value/number o)
- (let ((v (object->number o #f)))
- (if (is-a? x <js-object>)
- (object->string o #t)
- x)))
-
+ (if (is-a? o <js-object>)
+ (object->string o #t)
+ o))
+
(define (object->value o)
;; FIXME: if it's a date, we should try numbers first
(object->value/string o))
((boolean? x) (if x 1 0))
((null? x) 0)
((eq? x *undefined*) +nan.0)
- ((is-a? x <js-object>) (object->number o))
+ ((is-a? x <js-object>) (object->number x))
((string? x) (string->number x))
(else (throw 'TypeError o '->number))))
(define-syntax @implv
(syntax-rules ()
((_ sym)
- (-> (module-ref '(language ecmascript impl) 'sym #t)))))
+ (-> (@ '(language ecmascript impl) 'sym)))))
(define-syntax @impl
(syntax-rules ()
'())
(define (econs name gensym env)
- (acons name gensym env))
+ (acons name (-> (lexical name gensym)) env))
(define (lookup name env)
(or (assq-ref env name)
(define (compile-tree-il exp env opts)
(values
- (parse-tree-il (comp exp (empty-lexical-environment)))
+ (parse-tree-il
+ (-> (begin (@impl js-init)
+ (comp exp (empty-lexical-environment)))))
env
env))
((string ,str)
(-> (const str)))
(this
- (@impl get-this '()))
+ (@impl get-this))
((+ ,a)
(-> (apply (-> (primitive '+))
(@impl ->number (comp a e))
(-> (if (@impl ->boolean (comp test e))
(comp then e)
(comp else e))))
- ((if ,test ,then ,else)
+ ((if ,test ,then)
(-> (if (@impl ->boolean (comp test e))
(comp then e)
(@implv *undefined*))))
((ref ,id)
(lookup id e))
((var . ,forms)
- (-> (begin
- (map (lambda (form)
- (pmatch form
- ((,x ,y)
- (-> (define x (comp y e))))
- ((,x)
- (-> (define x (@implv *undefined*))))
- (else (error "bad var form" form))))
- forms))))
+ `(begin
+ ,@(map (lambda (form)
+ (pmatch form
+ ((,x ,y)
+ (-> (define x (comp y e))))
+ ((,x)
+ (-> (define x (@implv *undefined*))))
+ (else (error "bad var form" form))))
+ forms)))
+ ((begin)
+ (-> (void)))
+ ((begin ,form)
+ (comp form e))
((begin . ,forms)
`(begin ,@(map (lambda (x) (comp x e)) forms)))
((lambda ,formals ,body)
- (let ((%args (gensym "%args ")))
- (-> (lambda '%args %args '()
- (comp-body (econs '%args %args e) body formals '%args)))))
+ (let ((syms (map (lambda (x)
+ (gensym (string-append (symbol->string x) " ")))
+ formals)))
+ `(lambda ()
+ (lambda-case
+ ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
+ ,(comp-body e body formals syms))))))
((call/this ,obj ,prop . ,args)
(@impl call/this*
obj
- (-> (lambda '() '() '()
- `(apply ,(@impl pget obj prop) ,@args)))))
+ (-> (lambda '()
+ `(lambda-case
+ ((() #f #f #f () ())
+ (apply ,(@impl pget obj prop) ,@args)))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
(%continue (gensym "%continue ")))
(let ((e (econs '%loop %loop (econs '%continue %continue e))))
(-> (letrec '(%loop %continue) (list %loop %continue)
- (list (-> (lambda '() '() '()
- (-> (begin
- (comp statement e)
- (-> (apply (-> (lexical '%continue %continue)))
- )))))
-
- (-> (lambda '() '() '()
- (-> (if (@impl ->boolean (comp test e))
- (-> (apply (-> (lexical '%loop %loop))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (begin
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (apply (-> (lexical '%loop %loop))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
- (list (-> (lambda '() '() '()
- (-> (if (@impl ->boolean (comp test e))
- (-> (begin (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (begin (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
- (list (-> (lambda '() '() '()
- (-> (if (if test
- (@impl ->boolean (comp test e))
- (comp 'true e))
- (-> (begin (comp statement e)
- (comp (or inc '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (if (if test
+ (@impl ->boolean (comp test e))
+ (comp 'true e))
+ (-> (begin (comp statement e)
+ (comp (or inc '(begin)) e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
(-> (apply (-> (lexical '%continue %continue)))))))))))
(let ((e (econs '%enum %enum (econs '%continue %continue e))))
(-> (letrec '(%enum %continue) (list %enum %continue)
(list (@impl make-enumerator (comp object e))
- (-> (lambda '() '() '()
- (-> (if (@impl ->boolean
- (@impl pget
- (-> (lexical '%enum %enum))
- (-> (const 'length))))
- (-> (begin
- (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
- ,(-> (const 'pop))))
- e)
- (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ (-> (if (@impl ->boolean
+ (@impl pget
+ (-> (lexical '%enum %enum))
+ (-> (const 'length))))
+ (-> (begin
+ (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+ ,(-> (const 'pop))))
+ e)
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((block ,x)
(else
(error "compilation not yet implemented:" x)))))
-(define (comp-body e body formals %args)
+(define (comp-body e body formals formal-syms)
(define (process)
- (let lp ((in body) (out '()) (rvars (reverse formals)))
+ (let lp ((in body) (out '()) (rvars '()))
(pmatch in
(((var (,x) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
out
- (if (memq x rvars) rvars (cons x rvars))))
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
(((var (,x ,y) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
`((= (ref ,x) ,y) . ,out)
- (if (memq x rvars) rvars (cons x rvars))))
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
(((var) . ,rest)
(lp rest out rvars))
((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
(syms (map (lambda (x)
(gensym (string-append (symbol->string x) " ")))
names))
- (e (fold acons e names syms)))
- (let ((%argv (lookup %args e)))
- (let lp ((names names) (syms syms))
- (if (null? names)
- ;; fixme: here check for too many args
- (comp out e)
- (-> (let (list (car names)) (list (car syms))
- (list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
- (-> (@implv *undefined*))
- (-> (let1 (-> (apply (-> (primitive 'car)) %argv))
- (lambda (v)
- (-> (set! %argv
- (-> (apply (-> (primitive 'cdr)) %argv))))
- (-> (lexical v v))))))))
- (lp (cdr names) (cdr syms))))))))))
+ (e (fold econs (fold econs e formals formal-syms) names syms)))
+ (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)
+ (comp out e))))))
(define-language ecmascript
#:title "Guile ECMAScript"
#:version "3.0"
- #:reader (lambda () (read-ecmascript/1 (current-input-port)))
+ #:reader (lambda (port env) (read-ecmascript/1 port))
#:compilers `((tree-il . ,compile-tree-il))
;; a pretty-printer would be interesting.
#:printer write
(+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
(define (read-slash port div?)
- (let* ((c0 (read-char port))
- (c1 (peek-char port)))
+ (let ((c1 (begin
+ (read-char port)
+ (peek-char port))))
(cond
((eof-object? c1)
;; hmm. error if we're not looking for a div? ?
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
(make-module-ref loc module sym #t))
syms))
(make-application loc (make-primitive-ref loc 'list) vals)
- (make-lambda loc '() '() '() body)))
+ (make-lambda loc '()
+ (make-lambda-case #f '() #f #f #f '() '() body #f))))
; Handle access to a variable (reference/setting) correctly depending on
(map car all-lex-pairs)
(map cdr all-lex-pairs)
(lambda ()
- (make-lambda loc
- arg-names real-args '()
+ (make-lambda loc '()
+ (make-lambda-case
+ #f required #f
+ (if have-real-rest rest-name #f)
+ #f '()
+ (if have-real-rest
+ (append required-sym (list rest-sym))
+ required-sym)
(let* ((init-req (map (lambda (name-sym)
(make-lexical-ref loc (car name-sym)
(cdr name-sym)))
(make-let loc
optional-sym optional-sym
(map (lambda (sym) (nil-value loc)) optional-sym)
- full-body))))))))))))
+ full-body)))
+ #f))))))))))
; Build the code to handle setting of optional arguments that are present
; and updating the rest list.
(compile-expr condition)
full-body
(nil-value loc)))
- (iter-thunk (make-lambda loc '() '() '() lambda-body)))
+ (iter-thunk (make-lambda loc '()
+ (make-lambda-case #f '() #f #f #f '() '()
+ lambda-body #f))))
(make-letrec loc '(iterate) (list itersym) (list iter-thunk)
iter-call)))
;;; Guile Emac Lisp
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 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
(define-language elisp
#:title "Emacs Lisp"
#:version "0.0"
- #:reader (lambda () (read-elisp (current-input-port)))
+ #:reader (lambda (port env) (read-elisp port))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))
+++ /dev/null
-;;; Guile High Intermediate Language
-
-;; Copyright (C) 2001 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
-
-;;; Code:
-
-(define-module (language ghil)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module (ice-9 regex)
- #:export
- (ghil-env ghil-loc
-
- <ghil-void> make-ghil-void ghil-void?
- ghil-void-env ghil-void-loc
-
- <ghil-quote> make-ghil-quote ghil-quote?
- ghil-quote-env ghil-quote-loc ghil-quote-obj
-
- <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
- ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
-
- <ghil-unquote> make-ghil-unquote ghil-unquote?
- ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
-
- <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
- ghil-unquote-splicing-env ghil-unquote-splicing-loc ghil-unquote-splicing-exp
-
- <ghil-ref> make-ghil-ref ghil-ref?
- ghil-ref-env ghil-ref-loc ghil-ref-var
-
- <ghil-set> make-ghil-set ghil-set?
- ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
-
- <ghil-define> make-ghil-define ghil-define?
- ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
-
- <ghil-if> make-ghil-if ghil-if?
- ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
-
- <ghil-and> make-ghil-and ghil-and?
- ghil-and-env ghil-and-loc ghil-and-exps
-
- <ghil-or> make-ghil-or ghil-or?
- ghil-or-env ghil-or-loc ghil-or-exps
-
- <ghil-begin> make-ghil-begin ghil-begin?
- ghil-begin-env ghil-begin-loc ghil-begin-exps
-
- <ghil-bind> make-ghil-bind ghil-bind?
- ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
-
- <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
- ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body
-
- <ghil-lambda> make-ghil-lambda ghil-lambda?
- ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
- ghil-lambda-meta ghil-lambda-body
-
- <ghil-inline> make-ghil-inline ghil-inline?
- ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
-
- <ghil-call> make-ghil-call ghil-call?
- ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
-
- <ghil-mv-call> make-ghil-mv-call ghil-mv-call?
- ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer
-
- <ghil-values> make-ghil-values ghil-values?
- ghil-values-env ghil-values-loc ghil-values-values
-
- <ghil-values*> make-ghil-values* ghil-values*?
- ghil-values*-env ghil-values*-loc ghil-values*-values
-
- <ghil-var> make-ghil-var ghil-var?
- ghil-var-env ghil-var-name ghil-var-kind ghil-var-index
-
- <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
- ghil-toplevel-env-table
-
- <ghil-env> make-ghil-env ghil-env?
- ghil-env-parent ghil-env-table ghil-env-variables
-
- <ghil-reified-env> make-ghil-reified-env ghil-reified-env?
- ghil-reified-env-env ghil-reified-env-loc
-
- ghil-env-add!
- ghil-env-reify ghil-env-dereify
- ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
- ghil-var-at-module!
- call-with-ghil-environment call-with-ghil-bindings
-
- parse-ghil unparse-ghil))
-
-\f
-;;;
-;;; Parse tree
-;;;
-
-(define (print-ghil x port)
- (format port "#<ghil ~s>" (unparse-ghil x)))
-
-(define-type (<ghil> #:printer print-ghil
- #:common-slots (env loc))
- ;; Objects
- (<ghil-void>)
- (<ghil-quote> obj)
- (<ghil-quasiquote> exp)
- (<ghil-unquote> exp)
- (<ghil-unquote-splicing> exp)
- ;; Variables
- (<ghil-ref> var)
- (<ghil-set> var val)
- (<ghil-define> var val)
- ;; Controls
- (<ghil-if> test then else)
- (<ghil-and> exps)
- (<ghil-or> exps)
- (<ghil-begin> exps)
- (<ghil-bind> vars vals body)
- (<ghil-mv-bind> producer vars rest body)
- (<ghil-lambda> vars rest meta body)
- (<ghil-call> proc args)
- (<ghil-mv-call> producer consumer)
- (<ghil-inline> inline args)
- (<ghil-values> values)
- (<ghil-values*> values)
- (<ghil-reified-env>))
-
-
-\f
-;;;
-;;; Variables
-;;;
-
-(define-record <ghil-var> env name kind (index #f))
-
-\f
-;;;
-;;; Modules
-;;;
-
-\f
-;;;
-;;; Environments
-;;;
-
-(define-record <ghil-env> parent (table '()) (variables '()))
-(define-record <ghil-toplevel-env> (table '()))
-
-(define (ghil-env-ref env sym)
- (assq-ref (ghil-env-table env) sym))
-
-(define-macro (push! item loc)
- `(set! ,loc (cons ,item ,loc)))
-(define-macro (apush! k v loc)
- `(set! ,loc (acons ,k ,v ,loc)))
-(define-macro (apopq! k loc)
- `(set! ,loc (assq-remove! ,loc ,k)))
-
-(define (ghil-env-add! env var)
- (apush! (ghil-var-name var) var (ghil-env-table env))
- (push! var (ghil-env-variables env)))
-
-(define (ghil-env-remove! env var)
- (apopq! (ghil-var-name var) (ghil-env-table env)))
-
-(define (force-heap-allocation! var)
- (set! (ghil-var-kind var) 'external))
-
-
-\f
-;;;
-;;; Public interface
-;;;
-
-;; The following four functions used to be one, in ghil-lookup. Now they
-;; are four, to reflect the different intents. A bit of duplication, but
-;; that's OK. The common current is to find out where a variable will be
-;; stored at runtime.
-;;
-;; These functions first search the lexical environments. If the
-;; variable is not in the innermost environment, make sure the variable
-;; is marked as being "external" so that it goes on the heap. If the
-;; variable is being modified (via a set!), also make sure it's on the
-;; heap, so that other continuations see the changes to the var.
-;;
-;; If the variable is not found lexically, it is a toplevel variable,
-;; which will be looked up at runtime with respect to the module that
-;; was current when the lambda was bound, at runtime. The variable will
-;; be resolved when it is first used.
-(define (ghil-var-is-bound? env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (assoc-ref table key)))
- ((<ghil-env> parent table variables)
- (and (not (assq-ref table sym))
- (loop parent))))))
-
-(define (ghil-var-for-ref! env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (cond
- ((assq-ref table sym)
- => (lambda (var)
- (or (eq? e env)
- (force-heap-allocation! var))
- var))
- (else
- (loop parent)))))))
-
-(define (ghil-var-for-set! env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (cond
- ((assq-ref table sym)
- => (lambda (var)
- (force-heap-allocation! var)
- var))
- (else
- (loop parent)))))))
-
-(define (ghil-var-at-module! env modname sym interface?)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (list modname sym interface?)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var modname sym
- (if interface? 'public 'private))))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (loop parent)))))
-
-(define (ghil-var-define! toplevel sym)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref (ghil-toplevel-env-table toplevel) key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table toplevel))
- var))))
-
-(define (call-with-ghil-environment e syms func)
- (let* ((e (make-ghil-env e))
- (vars (map (lambda (s)
- (let ((v (make-ghil-var e s 'argument)))
- (ghil-env-add! e v) v))
- syms)))
- (func e vars)))
-
-(define (call-with-ghil-bindings e syms func)
- (let* ((vars (map (lambda (s)
- (let ((v (make-ghil-var e s 'local)))
- (ghil-env-add! e v) v))
- syms))
- (ret (func vars)))
- (for-each (lambda (v) (ghil-env-remove! e v)) vars)
- ret))
-
-(define (ghil-env-reify env)
- (let loop ((e env) (out '()))
- (record-case e
- ((<ghil-toplevel-env> table)
- (map (lambda (v)
- (cons (ghil-var-name v)
- (or (ghil-var-index v)
- (error "reify called before indices finalized"))))
- out))
- ((<ghil-env> parent table variables)
- (loop parent
- (append out
- (filter (lambda (v) (eq? (ghil-var-kind v) 'external))
- variables)))))))
-
-(define (ghil-env-dereify name-index-alist)
- (let* ((e (make-ghil-env (make-ghil-toplevel-env)))
- (vars (map (lambda (pair)
- (make-ghil-var e (car pair) 'external (cdr pair)))
- name-index-alist)))
- (set! (ghil-env-table e)
- (map (lambda (v) (cons (ghil-var-name v) v)) vars))
- (set! (ghil-env-variables e) vars)
- e))
-
-\f
-;;;
-;;; Parser
-;;;
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- (vector (assq-ref props 'line)
- (assq-ref props 'column)
- (assq-ref props 'filename))))))
-
-(define (parse-quasiquote e x level)
- (cond ((not (pair? x)) x)
- ((memq (car x) '(unquote unquote-splicing))
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj)
- (cond
- ((zero? level)
- (if (eq? (car x) 'unquote)
- (make-ghil-unquote e l (parse-ghil e obj))
- (make-ghil-unquote-splicing e l (parse-ghil e obj))))
- (else
- (list (car x) (parse-quasiquote e obj (1- level))))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- ((eq? (car x) 'quasiquote)
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- (else (cons (parse-quasiquote e (car x) level)
- (parse-quasiquote e (cdr x) level)))))
-
-(define (parse-ghil env exp)
- (let ((loc (location exp))
- (retrans (lambda (x) (parse-ghil env x))))
- (pmatch exp
- ((ref ,sym) (guard (symbol? sym))
- (make-ghil-ref env #f (ghil-var-for-ref! env sym)))
-
- (('quote ,exp) (make-ghil-quote env loc exp))
-
- ((void) (make-ghil-void env loc))
-
- ((lambda ,syms ,rest ,meta . ,body)
- (call-with-ghil-environment env syms
- (lambda (env vars)
- (make-ghil-lambda env loc vars rest meta
- (parse-ghil env `(begin ,@body))))))
-
- ((begin . ,body)
- (make-ghil-begin env loc (map retrans body)))
-
- ((bind ,syms ,exprs . ,body)
- (let ((vals (map retrans exprs)))
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
-
- ((bindrec ,syms ,exprs . ,body)
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
- (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
-
- ((set ,sym ,val)
- (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
-
- ((define ,sym ,val)
- (make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
-
- ((if ,test ,then ,else)
- (make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
-
- ((and . ,exps)
- (make-ghil-and env loc (map retrans exps)))
-
- ((or . ,exps)
- (make-ghil-or env loc (map retrans exps)))
-
- ((mv-bind ,syms ,rest ,producer . ,body)
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (make-ghil-mv-bind env loc (retrans producer) vars rest
- (map retrans body)))))
-
- ((call ,proc . ,args)
- (make-ghil-call env loc (retrans proc) (map retrans args)))
-
- ((mv-call ,producer ,consumer)
- (make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
-
- ((inline ,op . ,args)
- (make-ghil-inline env loc op (map retrans args)))
-
- ((values . ,values)
- (make-ghil-values env loc (map retrans values)))
-
- ((values* . ,values)
- (make-ghil-values* env loc (map retrans values)))
-
- ((compile-time-environment)
- (make-ghil-reified-env env loc))
-
- ((quasiquote ,exp)
- (make-ghil-quasiquote env loc (parse-quasiquote env exp 0)))
-
- (else
- (error "unrecognized GHIL" exp)))))
-
-(define (unparse-ghil ghil)
- (record-case ghil
- ((<ghil-void> env loc)
- '(void))
- ((<ghil-quote> env loc obj)
- `(,'quote ,obj))
- ((<ghil-quasiquote> env loc exp)
- `(,'quasiquote ,(let lp ((x exp))
- (cond ((struct? x) (unparse-ghil x))
- ((pair? x) (cons (lp (car x)) (lp (cdr x))))
- (else x)))))
- ((<ghil-unquote> env loc exp)
- `(,'unquote ,(unparse-ghil exp)))
- ((<ghil-unquote-splicing> env loc exp)
- `(,'unquote-splicing ,(unparse-ghil exp)))
- ;; Variables
- ((<ghil-ref> env loc var)
- `(ref ,(ghil-var-name var)))
- ((<ghil-set> env loc var val)
- `(set ,(ghil-var-name var) ,(unparse-ghil val)))
- ((<ghil-define> env loc var val)
- `(define ,(ghil-var-name var) ,(unparse-ghil val)))
- ;; Controls
- ((<ghil-if> env loc test then else)
- `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
- ((<ghil-and> env loc exps)
- `(and ,@(map unparse-ghil exps)))
- ((<ghil-or> env loc exps)
- `(or ,@(map unparse-ghil exps)))
- ((<ghil-begin> env loc exps)
- `(begin ,@(map unparse-ghil exps)))
- ((<ghil-bind> env loc vars vals body)
- `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
- ,(unparse-ghil body)))
- ((<ghil-mv-bind> env loc producer vars rest body)
- `(mv-bind ,(map ghil-var-name vars) ,rest
- ,(unparse-ghil producer) ,(unparse-ghil body)))
- ((<ghil-lambda> env loc vars rest meta body)
- `(lambda ,(map ghil-var-name vars) ,rest ,meta
- ,(unparse-ghil body)))
- ((<ghil-call> env loc proc args)
- `(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
- ((<ghil-mv-call> env loc producer consumer)
- `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
- ((<ghil-inline> env loc inline args)
- `(inline ,inline ,@(map unparse-ghil args)))
- ((<ghil-values> env loc values)
- `(values ,@(map unparse-ghil values)))
- ((<ghil-values*> env loc values)
- `(values* ,@(map unparse-ghil values)))
- ((<ghil-reified-env> env loc)
- `(compile-time-environment))))
+++ /dev/null
-;;; GHIL -> GLIL compiler
-
-;; Copyright (C) 2001 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
-
-;;; Code:
-
-(define-module (language ghil compile-glil)
- #:use-module (system base syntax)
- #:use-module (language glil)
- #:use-module (language ghil)
- #:use-module (ice-9 common-list)
- #:export (compile-glil))
-
-(define (compile-glil x e opts)
- (if (memq #:O opts) (set! x (optimize x)))
- (values (codegen x)
- (and e (cons (car e) (cddr e)))
- e))
-
-\f
-;;;
-;;; Stage 2: Optimization
-;;;
-
-(define (lift-variables! env)
- (let ((parent-env (ghil-env-parent env)))
- (for-each (lambda (v)
- (case (ghil-var-kind v)
- ((argument) (set! (ghil-var-kind v) 'local)))
- (set! (ghil-var-env v) parent-env)
- (ghil-env-add! parent-env v))
- (ghil-env-variables env))))
-
-;; The premise of this, unused, approach to optimization is that you can
-;; determine the environment of a variable lexically, because they have
-;; been alpha-renamed. It makes the transformations *much* easier.
-;; Unfortunately it doesn't work yet.
-(define (optimize* x)
- (transform-record (<ghil> env loc) x
- ((quasiquote exp)
- (define (optimize-qq x)
- (cond ((list? x) (map optimize-qq x))
- ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
- ((record? x) (optimize x))
- (else x)))
- (-> (quasiquote (optimize-qq x))))
-
- ((unquote exp)
- (-> (unquote (optimize exp))))
-
- ((unquote-splicing exp)
- (-> (unquote-splicing (optimize exp))))
-
- ((set var val)
- (-> (set var (optimize val))))
-
- ((define var val)
- (-> (define var (optimize val))))
-
- ((if test then else)
- (-> (if (optimize test) (optimize then) (optimize else))))
-
- ((and exps)
- (-> (and (map optimize exps))))
-
- ((or exps)
- (-> (or (map optimize exps))))
-
- ((begin exps)
- (-> (begin (map optimize exps))))
-
- ((bind vars vals body)
- (-> (bind vars (map optimize vals) (optimize body))))
-
- ((mv-bind producer vars rest body)
- (-> (mv-bind (optimize producer) vars rest (optimize body))))
-
- ((inline inst args)
- (-> (inline inst (map optimize args))))
-
- ((call (proc (lambda vars (rest #f) meta body)) args)
- (-> (bind vars (optimize args) (optimize body))))
-
- ((call proc args)
- (-> (call (optimize proc) (map optimize args))))
-
- ((lambda vars rest meta body)
- (-> (lambda vars rest meta (optimize body))))
-
- ((mv-call producer (consumer (lambda vars rest meta body)))
- (-> (mv-bind (optimize producer) vars rest (optimize body))))
-
- ((mv-call producer consumer)
- (-> (mv-call (optimize producer) (optimize consumer))))
-
- ((values values)
- (-> (values (map optimize values))))
-
- ((values* values)
- (-> (values* (map optimize values))))
-
- (else
- (error "unrecognized GHIL" x))))
-
-(define (optimize x)
- (record-case x
- ((<ghil-set> env loc var val)
- (make-ghil-set env var (optimize val)))
-
- ((<ghil-define> env loc var val)
- (make-ghil-define env var (optimize val)))
-
- ((<ghil-if> env loc test then else)
- (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
-
- ((<ghil-and> env loc exps)
- (make-ghil-and env loc (map optimize exps)))
-
- ((<ghil-or> env loc exps)
- (make-ghil-or env loc (map optimize exps)))
-
- ((<ghil-begin> env loc exps)
- (make-ghil-begin env loc (map optimize exps)))
-
- ((<ghil-bind> env loc vars vals body)
- (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
-
- ((<ghil-lambda> env loc vars rest meta body)
- (make-ghil-lambda env loc vars rest meta (optimize body)))
-
- ((<ghil-inline> env loc instruction args)
- (make-ghil-inline env loc instruction (map optimize args)))
-
- ((<ghil-call> env loc proc args)
- (let ((parent-env env))
- (record-case proc
- ;; ((@lambda (VAR...) BODY...) ARG...) =>
- ;; (@let ((VAR ARG) ...) BODY...)
- ((<ghil-lambda> env loc vars rest meta body)
- (cond
- ((not rest)
- (lift-variables! env)
- (make-ghil-bind parent-env loc (map optimize args)))
- (else
- (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
- (else
- (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
-
- ((<ghil-mv-call> env loc producer consumer)
- (record-case consumer
- ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
- ;; (mv-let PRODUCER ARGS BODY...)
- ((<ghil-lambda> env loc vars rest meta body)
- (lift-variables! env)
- (make-ghil-mv-bind producer vars rest body))
- (else
- (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
-
- (else x)))
-
-\f
-;;;
-;;; Stage 3: Code generation
-;;;
-
-(define *ia-void* (make-glil-void))
-(define *ia-drop* (make-glil-call 'drop 1))
-(define *ia-return* (make-glil-call 'return 1))
-
-(define (make-label) (gensym ":L"))
-
-(define (make-glil-var op env var)
- (case (ghil-var-kind var)
- ((argument)
- (make-glil-local op (ghil-var-index var)))
- ((local)
- (make-glil-local op (ghil-var-index var)))
- ((external)
- (do ((depth 0 (1+ depth))
- (e env (ghil-env-parent e)))
- ((eq? e (ghil-var-env var))
- (make-glil-external op depth (ghil-var-index var)))))
- ((toplevel)
- (make-glil-toplevel op (ghil-var-name var)))
- ((public private)
- (make-glil-module op (ghil-var-env var) (ghil-var-name var)
- (eq? (ghil-var-kind var) 'public)))
- (else (error "Unknown kind of variable:" var))))
-
-(define (constant? x)
- (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
- ((pair? x) (and (constant? (car x))
- (constant? (cdr x))))
- ((vector? x) (let lp ((i (vector-length x)))
- (or (zero? i)
- (and (constant? (vector-ref x (1- i)))
- (lp (1- i))))))))
-
-(define (codegen ghil)
- (let ((stack '()))
- (define (push-code! loc code)
- (set! stack (cons code stack))
- (if loc (set! stack (cons (make-glil-source loc) stack))))
- (define (var->binding var)
- (list (ghil-var-name var) (let ((kind (ghil-var-kind var)))
- (case kind ((argument) 'local) (else kind)))
- (ghil-var-index var)))
- (define (push-bindings! loc vars)
- (if (not (null? vars))
- (push-code! loc (make-glil-bind (map var->binding vars)))))
- (define (comp tree tail drop)
- (define (push-label! label)
- (push-code! #f (make-glil-label label)))
- (define (push-branch! loc inst label)
- (push-code! loc (make-glil-branch inst label)))
- (define (push-call! loc inst args)
- (for-each comp-push args)
- (push-code! loc (make-glil-call inst (length args))))
- ;; possible tail position
- (define (comp-tail tree) (comp tree tail drop))
- ;; push the result
- (define (comp-push tree) (comp tree #f #f))
- ;; drop the result
- (define (comp-drop tree) (comp tree #f #t))
- ;; drop the result if unnecessary
- (define (maybe-drop)
- (if drop (push-code! #f *ia-drop*)))
- ;; return here if necessary
- (define (maybe-return)
- (if tail (push-code! #f *ia-return*)))
- ;; return this code if necessary
- (define (return-code! loc code)
- (if (not drop) (push-code! loc code))
- (maybe-return))
- ;; return void if necessary
- (define (return-void!)
- (return-code! #f *ia-void*))
- ;; return object if necessary
- (define (return-object! loc obj)
- (return-code! loc (make-glil-const obj)))
- ;;
- ;; dispatch
- (record-case tree
- ((<ghil-void>)
- (return-void!))
-
- ((<ghil-quote> env loc obj)
- (return-object! loc obj))
-
- ((<ghil-quasiquote> env loc exp)
- (let loop ((x exp) (in-car? #f))
- (cond
- ((list? x)
- (push-call! #f 'mark '())
- (for-each (lambda (x) (loop x #t)) x)
- (push-call! #f 'list-mark '()))
- ((pair? x)
- (push-call! #f 'mark '())
- (loop (car x) #t)
- (loop (cdr x) #f)
- (push-call! #f 'cons-mark '()))
- ((record? x)
- (record-case x
- ((<ghil-unquote> env loc exp)
- (comp-push exp))
- ((<ghil-unquote-splicing> env loc exp)
- (if (not in-car?)
- (error "unquote-splicing in the cdr of a pair" exp))
- (comp-push exp)
- (push-call! #f 'list-break '()))))
- ((constant? x)
- (push-code! #f (make-glil-const x)))
- (else
- (error "element of quasiquote can't be compiled" x))))
- (maybe-drop)
- (maybe-return))
-
- ((<ghil-unquote> env loc exp)
- (error "unquote outside of quasiquote" exp))
-
- ((<ghil-unquote-splicing> env loc exp)
- (error "unquote-splicing outside of quasiquote" exp))
-
- ((<ghil-ref> env loc var)
- (return-code! loc (make-glil-var 'ref env var)))
-
- ((<ghil-set> env loc var val)
- (comp-push val)
- (push-code! loc (make-glil-var 'set env var))
- (return-void!))
-
- ((<ghil-define> env loc var val)
- (comp-push val)
- (push-code! loc (make-glil-var 'define env var))
- (return-void!))
-
- ((<ghil-if> env loc test then else)
- ;; TEST
- ;; (br-if-not L1)
- ;; THEN
- ;; (br L2)
- ;; L1: ELSE
- ;; L2:
- (let ((L1 (make-label)) (L2 (make-label)))
- (comp-push test)
- (push-branch! loc 'br-if-not L1)
- (comp-tail then)
- (if (not tail) (push-branch! #f 'br L2))
- (push-label! L1)
- (comp-tail else)
- (if (not tail) (push-label! L2))))
-
- ((<ghil-and> env loc exps)
- ;; EXP
- ;; (br-if-not L1)
- ;; ...
- ;; TAIL
- ;; (br L2)
- ;; L1: (const #f)
- ;; L2:
- (cond ((null? exps) (return-object! loc #t))
- ((null? (cdr exps)) (comp-tail (car exps)))
- (else
- (let ((L1 (make-label)) (L2 (make-label)))
- (let lp ((exps exps))
- (cond ((null? (cdr exps))
- (comp-tail (car exps))
- (push-branch! #f 'br L2)
- (push-label! L1)
- (return-object! #f #f)
- (push-label! L2)
- (maybe-return))
- (else
- (comp-push (car exps))
- (push-branch! #f 'br-if-not L1)
- (lp (cdr exps)))))))))
-
- ((<ghil-or> env loc exps)
- ;; EXP
- ;; (dup)
- ;; (br-if L1)
- ;; (drop)
- ;; ...
- ;; TAIL
- ;; L1:
- (cond ((null? exps) (return-object! loc #f))
- ((null? (cdr exps)) (comp-tail (car exps)))
- (else
- (let ((L1 (make-label)))
- (let lp ((exps exps))
- (cond ((null? (cdr exps))
- (comp-tail (car exps))
- (push-label! L1)
- (maybe-return))
- (else
- (comp-push (car exps))
- (if (not drop)
- (push-call! #f 'dup '()))
- (push-branch! #f 'br-if L1)
- (if (not drop)
- (push-code! loc (make-glil-call 'drop 1)))
- (lp (cdr exps)))))))))
-
- ((<ghil-begin> env loc exps)
- ;; EXPS...
- ;; TAIL
- (if (null? exps)
- (return-void!)
- (do ((exps exps (cdr exps)))
- ((null? (cdr exps))
- (comp-tail (car exps)))
- (comp-drop (car exps)))))
-
- ((<ghil-bind> env loc vars vals body)
- ;; VALS...
- ;; (set VARS)...
- ;; BODY
- (for-each comp-push vals)
- (push-bindings! loc vars)
- (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
- (reverse vars))
- (comp-tail body)
- (push-code! #f (make-glil-unbind)))
-
- ((<ghil-mv-bind> env loc producer vars rest body)
- ;; VALS...
- ;; (set VARS)...
- ;; BODY
- (let ((MV (make-label)))
- (comp-push producer)
- (push-code! loc (make-glil-mv-call 0 MV))
- (push-code! #f (make-glil-const 1))
- (push-label! MV)
- (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
- (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
- (reverse vars)))
- (comp-tail body)
- (push-code! #f (make-glil-unbind)))
-
- ((<ghil-lambda> env loc vars rest meta body)
- (return-code! loc (codegen tree)))
-
- ((<ghil-inline> env loc inline args)
- ;; ARGS...
- ;; (INST NARGS)
- (let ((tail-table '((call . goto/args)
- (apply . goto/apply)
- (call/cc . goto/cc))))
- (cond ((and tail (assq-ref tail-table inline))
- => (lambda (tail-inst)
- (push-call! loc tail-inst args)))
- (else
- (push-call! loc inline args)
- (maybe-drop)
- (maybe-return)))))
-
- ((<ghil-values> env loc values)
- (cond (tail ;; (lambda () (values 1 2))
- (push-call! loc 'return/values values))
- (drop ;; (lambda () (values 1 2) 3)
- (for-each comp-drop values))
- (else ;; (lambda () (list (values 10 12) 1))
- (push-code! #f (make-glil-const 'values))
- (push-code! #f (make-glil-call 'link-now 1))
- (push-code! #f (make-glil-call 'variable-ref 0))
- (push-call! loc 'call values))))
-
- ((<ghil-values*> env loc values)
- (cond (tail ;; (lambda () (apply values '(1 2)))
- (push-call! loc 'return/values* values))
- (drop ;; (lambda () (apply values '(1 2)) 3)
- (for-each comp-drop values))
- (else ;; (lambda () (list (apply values '(10 12)) 1))
- (push-code! #f (make-glil-const 'values))
- (push-code! #f (make-glil-call 'link-now 1))
- (push-code! #f (make-glil-call 'variable-ref 0))
- (push-call! loc 'apply values))))
-
- ((<ghil-call> env loc proc args)
- ;; PROC
- ;; ARGS...
- ;; ([tail-]call NARGS)
- (comp-push proc)
- (let ((nargs (length args)))
- (cond ((< nargs 255)
- (push-call! loc (if tail 'goto/args 'call) args))
- (else
- (push-call! loc 'mark '())
- (for-each comp-push args)
- (push-call! loc 'list-mark '())
- (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
- (maybe-drop))
-
- ((<ghil-mv-call> env loc producer consumer)
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (let ((MV (make-label)) (POST (make-label)))
- (comp-push consumer)
- (comp-push producer)
- (push-code! loc (make-glil-mv-call 0 MV))
- (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
- (cond ((not tail)
- (push-branch! #f 'br POST)))
- (push-label! MV)
- (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
- (cond ((not tail)
- (push-label! POST)
- (maybe-drop)))))
-
- ((<ghil-reified-env> env loc)
- (return-object! loc (ghil-env-reify env)))))
-
- ;;
- ;; main
- (record-case ghil
- ((<ghil-lambda> env loc vars rest meta body)
- (let* ((evars (ghil-env-variables env))
- (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
- (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
- (nargs (allocate-indices-linearly! vars))
- (nlocs (allocate-locals! locs body nargs))
- (nexts (allocate-indices-linearly! exts)))
- ;; meta bindings
- (push-bindings! #f vars)
- ;; push on definition source location
- (if loc (set! stack (cons (make-glil-source loc) stack)))
- ;; copy args to the heap if they're marked as external
- (do ((n 0 (1+ n))
- (l vars (cdr l)))
- ((null? l))
- (let ((v (car l)))
- (case (ghil-var-kind v)
- ((external)
- (push-code! #f (make-glil-local 'ref n))
- (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
- ;; compile body
- (comp body #t #f)
- ;; create GLIL
- (make-glil-program nargs (if rest 1 0) nlocs nexts meta
- (reverse! stack)))))))
-
-(define (allocate-indices-linearly! vars)
- (do ((n 0 (1+ n))
- (l vars (cdr l)))
- ((null? l) n)
- (let ((v (car l))) (set! (ghil-var-index v) n))))
-
-(define (allocate-locals! vars body nargs)
- (let ((free '()) (nlocs nargs))
- (define (allocate! var)
- (cond
- ((pair? free)
- (set! (ghil-var-index var) (car free))
- (set! free (cdr free)))
- (else
- (set! (ghil-var-index var) nlocs)
- (set! nlocs (1+ nlocs)))))
- (define (deallocate! var)
- (set! free (cons (ghil-var-index var) free)))
- (let lp ((x body))
- (record-case x
- ((<ghil-void>))
- ((<ghil-quote>))
- ((<ghil-quasiquote> exp)
- (let qlp ((x exp))
- (cond ((list? x) (for-each qlp x))
- ((pair? x) (qlp (car x)) (qlp (cdr x)))
- ((record? x)
- (record-case x
- ((<ghil-unquote> exp) (lp exp))
- ((<ghil-unquote-splicing> exp) (lp exp)))))))
- ((<ghil-unquote> exp)
- (lp exp))
- ((<ghil-unquote-splicing> exp)
- (lp exp))
- ((<ghil-reified-env>))
- ((<ghil-set> val)
- (lp val))
- ((<ghil-ref>))
- ((<ghil-define> val)
- (lp val))
- ((<ghil-if> test then else)
- (lp test) (lp then) (lp else))
- ((<ghil-and> exps)
- (for-each lp exps))
- ((<ghil-or> exps)
- (for-each lp exps))
- ((<ghil-begin> exps)
- (for-each lp exps))
- ((<ghil-bind> vars vals body)
- (for-each allocate! vars)
- (for-each lp vals)
- (lp body)
- (for-each deallocate! vars))
- ((<ghil-mv-bind> vars producer body)
- (lp producer)
- (for-each allocate! vars)
- (lp body)
- (for-each deallocate! vars))
- ((<ghil-inline> args)
- (for-each lp args))
- ((<ghil-call> proc args)
- (lp proc)
- (for-each lp args))
- ((<ghil-lambda>))
- ((<ghil-mv-call> producer consumer)
- (lp producer)
- (lp consumer))
- ((<ghil-values> values)
- (for-each lp values))
- ((<ghil-values*> values)
- (for-each lp values))))
- nlocs))
+++ /dev/null
-;;; Guile High Intermediate Language
-
-;; Copyright (C) 2001 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
-
-;;; Code:
-
-(define-module (language ghil spec)
- #:use-module (system base language)
- #:use-module (language glil)
- #:use-module (language ghil)
- #:use-module (language ghil compile-glil)
- #:export (ghil))
-
-(define (write-ghil exp . port)
- (apply write (unparse-ghil exp) port))
-
-(define (parse x)
- (call-with-ghil-environment (make-ghil-toplevel-env (current-module)) '()
- (lambda (env vars)
- (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
-
-(define (join exps env)
- (if (or-map (lambda (x)
- (or (not (ghil-lambda? x))
- (ghil-lambda-rest x)
- (memq 'argument
- (map ghil-var-kind
- (ghil-env-variables (ghil-lambda-env x))))))
- exps)
- (error "GHIL expressions to join must be thunks"))
-
- (let ((env (make-ghil-env env '()
- (apply append
- (map ghil-env-variables
- (map ghil-lambda-env exps))))))
- (make-ghil-lambda env #f '() #f '()
- (make-ghil-begin env #f
- (map ghil-lambda-body exps)))))
-
-(define-language ghil
- #:title "Guile High Intermediate Language (GHIL)"
- #:version "0.3"
- #:reader read
- #:printer write-ghil
- #:parser parse
- #:joiner join
- #:compilers `((glil . ,compile-glil))
- )
#:use-module ((srfi srfi-1) #:select (fold))
#:export
(<glil-program> make-glil-program glil-program?
- glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body
+ <glil-std-prelude> make-glil-std-prelude glil-std-prelude?
+ glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
+
+ <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
+ glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
+ glil-opt-prelude-nlocs glil-opt-prelude-else-label
+
+ <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
+ glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
+ glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
+ glil-kw-prelude-nlocs glil-kw-prelude-else-label
+
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
(define-type (<glil> #:printer print-glil)
;; Meta operations
- (<glil-program> nargs nrest nlocs meta body)
+ (<glil-program> meta body)
+ (<glil-std-prelude> nreq nlocs else-label)
+ (<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ (<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
(define (parse-glil x)
(pmatch x
- ((program ,nargs ,nrest ,nlocs ,meta . ,body)
- (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
+ ((program ,meta . ,body)
+ (make-glil-program meta (map parse-glil body)))
+ ((std-prelude ,nreq ,nlocs ,else-label)
+ (make-glil-std-prelude nreq nlocs else-label))
+ ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
+ (make-glil-opt-prelude nreq nopt rest nlocs else-label))
+ ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
+ (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
- ((label ,label) (make-label label))
+ ((label ,label) (make-glil-label label))
((branch ,inst ,label) (make-glil-branch inst label))
((call ,inst ,nargs) (make-glil-call inst nargs))
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
(define (unparse-glil glil)
(record-case glil
;; meta
- ((<glil-program> nargs nrest nlocs meta body)
- `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
+ ((<glil-program> meta body)
+ `(program ,meta ,@(map unparse-glil body)))
+ ((<glil-std-prelude> nreq nlocs else-label)
+ `(std-prelude ,nreq ,nlocs ,else-label))
+ ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
+ ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+ `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))
(else
(lp (cdr in) out filename)))))))
-(define (make-meta bindings sources tail)
- (if (and (null? bindings) (null? sources) (null? tail))
+(define (make-meta bindings sources arities tail)
+ ;; sounds silly, but the only case in which we have no arities is when
+ ;; compiling a meta procedure.
+ (if (and (null? bindings) (null? sources) (null? arities) (null? tail))
#f
(compile-assembly
- (make-glil-program 0 0 0 '()
+ (make-glil-program '()
(list
- (make-glil-const `(,bindings ,sources ,@tail))
+ (make-glil-const `(,bindings ,sources ,arities ,@tail))
(make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
(assoc-ref-or-acons alist x
(lambda (x alist)
(+ (length alist) *module*))))
+(define (make-object-table objects)
+ (and (not (null? objects))
+ (list->vector (cons #f objects))))
+
+;; A functional arities thingamajiggy.
+;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
+(define (open-arity addr nreq nopt rest kw arities)
+ (cons
+ (cond
+ (kw (list addr nreq nopt rest kw))
+ (rest (list addr nreq nopt rest))
+ (nopt (list addr nreq nopt))
+ (nreq (list addr nreq))
+ (else (list addr)))
+ arities))
+(define (close-arity addr arities)
+ (pmatch arities
+ (() '())
+ (((,start . ,tail) . ,rest)
+ `((,start ,addr . ,tail) . ,rest))
+ (else (error "bad arities" arities))))
+(define (begin-arity end start nreq nopt rest kw arities)
+ (open-arity start nreq nopt rest kw (close-arity end arities)))
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil #t '(()) '() '() #f -1)
+ (glil->assembly glil #t '(()) '() '() #f '() -1)
(car code)))
-(define (make-object-table objects)
- (and (not (null? objects))
- (list->vector (cons #f objects))))
(define (glil->assembly glil toplevel? bindings
- source-alist label-alist object-alist addr)
+ source-alist label-alist object-alist arities addr)
(define (emit-code x)
- (values x bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist arities))
(define (emit-code/object x object-alist)
- (values x bindings source-alist label-alist object-alist))
-
+ (values x bindings source-alist label-alist object-alist arities))
+ (define (emit-code/arity x nreq nopt rest kw)
+ (values x bindings source-alist label-alist object-alist
+ (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))
+
(record-case glil
- ((<glil-program> nargs nrest nlocs meta body)
+ ((<glil-program> meta body)
(define (process-body)
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ (label-alist '()) (object-alist (if toplevel? #f '()))
+ (arities '()) (addr 0))
(cond
((null? body)
(values (reverse code)
(limn-sources (reverse! source-alist))
(reverse label-alist)
(and object-alist (map car (reverse object-alist)))
+ (reverse (close-arity addr arities))
addr))
(else
- (receive (subcode bindings source-alist label-alist object-alist)
+ (receive (subcode bindings source-alist label-alist object-alist
+ arities)
(glil->assembly (car body) #f bindings
- source-alist label-alist object-alist addr)
+ source-alist label-alist object-alist
+ arities addr)
(lp (cdr body) (append (reverse subcode) code)
- bindings source-alist label-alist object-alist
+ bindings source-alist label-alist object-alist arities
(addr+ addr subcode)))))))
- (receive (code bindings sources labels objects len)
+ (receive (code bindings sources labels objects arities len)
(process-body)
- (let* ((meta (make-meta bindings sources meta))
+ (let* ((meta (make-meta bindings sources arities meta))
(meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
- (prog `(load-program ,nargs ,nrest ,nlocs ,labels
+ (prog `(load-program ,labels
,(+ len meta-pad)
,meta
,@code
`(,@table-code
,@(align-program prog (addr+ addr table-code)))))))))))))
+ ((<glil-std-prelude> nreq nlocs else-label)
+ (emit-code/arity
+ `(,(if else-label
+ `(br-if-nargs-ne ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label)
+ `(assert-nargs-ee ,(quotient nreq 256)
+ ,(modulo nreq 256)))
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))
+ nreq #f #f #f))
+
+ ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ (let ((bind-required
+ (if else-label
+ `((br-if-nargs-lt ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label))
+ `((assert-nargs-ge ,(quotient nreq 256)
+ ,(modulo nreq 256)))))
+ (bind-optionals
+ (if (zero? nopt)
+ '()
+ `((bind-optionals ,(quotient (+ nopt nreq) 256)
+ ,(modulo (+ nreq nopt) 256)))))
+ (bind-rest
+ (cond
+ (rest
+ `((push-rest ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256))))
+ (else
+ (if else-label
+ `((br-if-nargs-gt ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256)
+ ,else-label))
+ `((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256))))))))
+ (emit-code/arity
+ `(,@bind-required
+ ,@bind-optionals
+ ,@bind-rest
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))
+ nreq nopt rest #f)))
+
+ ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+ (receive (kw-idx object-alist)
+ (object-index-and-alist kw object-alist)
+ (let* ((bind-required
+ (if else-label
+ `((br-if-nargs-lt ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label))
+ `((assert-nargs-ge ,(quotient nreq 256)
+ ,(modulo nreq 256)))))
+ (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
+ (bind-optionals-and-shuffle
+ `((bind-optionals/shuffle
+ ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256)
+ ,(quotient ntotal 256)
+ ,(modulo ntotal 256))))
+ (bind-kw
+ ;; when this code gets called, all optionals are filled
+ ;; in, space has been made for kwargs, and the kwargs
+ ;; themselves have been shuffled above the slots for all
+ ;; req/opt/kwargs locals.
+ `((bind-kwargs
+ ,(quotient kw-idx 256)
+ ,(modulo kw-idx 256)
+ ,(quotient ntotal 256)
+ ,(modulo ntotal 256)
+ ,(logior (if rest 2 0)
+ (if allow-other-keys? 1 0)))))
+ (bind-rest
+ (if rest
+ `((bind-rest ,(quotient ntotal 256)
+ ,(modulo ntotal 256)
+ ,(quotient rest 256)
+ ,(modulo rest 256)))
+ '())))
+
+ (let ((code `(,@bind-required
+ ,@bind-optionals-and-shuffle
+ ,@bind-kw
+ ,@bind-rest
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))))
+ (values code bindings source-alist label-alist object-alist
+ (begin-arity addr (addr+ addr code) nreq nopt rest
+ (and kw (cons allow-other-keys? kw))
+ arities))))))
+
((<glil-bind> vars)
(values '()
(open-binding bindings vars addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
(open-binding bindings vars addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-unbind>)
(values '()
(close-binding bindings addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-source> props)
(values '()
bindings
(acons addr props source-alist)
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-void>)
(emit-code '((void))))
((box) `((box ,index)))
((empty-box) `((empty-box ,index)))
((fix) `((fix-closure 0 ,index)))
+ ((bound?) (if boxed?
+ `((local-ref ,index)
+ (variable-bound?))
+ `((local-bound? ,index))))
(else (error "what" op)))
- (let ((a (quotient i 256))
- (b (modulo i 256)))
+ (let ((a (quotient index 256))
+ (b (modulo index 256)))
`((,(case op
((ref)
(if boxed?
(long-local-set ,a ,b)))
((fix)
`((fix-closure ,a ,b)))
+ ((bound?)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-bound?))
+ `((long-local-bound? ,a ,b))))
(else (error "what" op)))
,index))))
`((,(case op
bindings
source-alist
(acons label (addr+ addr code) label-alist)
- object-alist)))
+ object-alist
+ arities)))
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
(define (decompile-toplevel x)
(pmatch x
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
- (decompile-load-program nargs nrest nlocs
- (decompile-meta meta)
+ ((load-program ,labels ,len ,meta . ,body)
+ (decompile-load-program (decompile-meta meta)
body labels #f))
(else
(error "invalid assembly" x))))
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
-(define (decompile-load-program nargs nrest nlocs meta body labels
+(define (decompile-load-program meta body labels
objects)
(let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x))))
(cond
((null? in)
(or (null? stack) (error "leftover stack insts" stack body))
- (make-glil-program nargs nrest nlocs props (reverse out) #f))
+ (make-glil-program props (reverse out)))
((pop-bindings! pos)
=> (lambda (bindings)
(lp in stack
(lp (cdr in) (cons #f stack) out (1+ pos)))
((make-nil)
(lp (cdr in) (cons %nil stack) out (1+ pos)))
- ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body)
+ ((load-program ,labels ,sublen ,meta . ,body)
(lp (cdr in)
- (cons (decompile-load-program a b c d (decompile-meta meta)
+ (cons (decompile-load-program (decompile-meta meta)
body labels (car stack))
(cdr stack))
out
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 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
(define-language glil
#:title "Guile Lowlevel Intermediate Language (GLIL)"
#:version "0.3"
- #:reader read
+ #:reader (lambda (port env) (read port))
#:printer write-glil
#:parser parse-glil
#:compilers `((assembly . ,compile-asm))
#:use-module (system base language)
#:use-module (system vm objcode)
#:use-module (system vm program)
- #:export (objcode make-objcode-env))
-
-(define (make-objcode-env module externals)
- (cons module externals))
-
-(define (objcode-env-module env)
- (if env (car env) (current-module)))
-
-(define (objcode-env-externals env)
- (and env (vector? (cdr env)) (cdr env)))
+ #:export (objcode))
(define (objcode->value x e opts)
- (let ((thunk (make-program x #f (objcode-env-externals e))))
- (if e
+ (let ((thunk (make-program x #f #f)))
+ (if (eq? e (current-module))
+ ;; save a cons in this case
+ (values (thunk) e e)
(save-module-excursion
(lambda ()
- (set-current-module (objcode-env-module e))
- (values (thunk) #f e)))
- (values (thunk) #f e))))
+ (set-current-module e)
+ (values (thunk) e e))))))
;; since locals are allocated on the stack and can have limited scope,
;; in many cases we use one local for more than one lexical variable. so
(meta (program-meta x))
(free-vars (program-free-variables x))
(binds (program-bindings x))
- (srcs (program-sources x))
- (nargs (arity:nargs (program-arity x))))
+ (srcs (program-sources x)))
(let ((blocs (and binds (collapse-locals binds))))
(values (program-objcode x)
`((objects . ,objs)
+++ /dev/null
-;;; R5RS core environment
-
-;; Copyright (C) 2001 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
-
-;;; Code:
-
-;; Non standard procedures
-
-(@define void (@lambda () (@void)))
-
-;; 6. Standard procedures
-
-;;; 6.1 Equivalence predicates
-
-(@define eq? (@lambda (x y) (@eq? x y)))
-(@define eqv? (@ Core::eqv?))
-(@define equal? (@ Core::equal?))
-
-;;; 6.2 Numbers
-
-(@define number? (@ Core::number?))
-(@define complex? (@ Core::complex?))
-(@define real? (@ Core::real?))
-(@define rational? (@ Core::rational?))
-(@define integer? (@ Core::integer?))
-
-(@define exact? (@ Core::exact?))
-(@define inexact? (@ Core::inexact?))
-
-(@define = (@ Core::=))
-(@define < (@ Core::<))
-(@define > (@ Core::>))
-(@define <= (@ Core::<=))
-(@define >= (@ Core::>=))
-
-(@define zero? (@ Core::zero?))
-(@define positive? (@ Core::positive?))
-(@define negative? (@ Core::negative?))
-(@define odd? (@ Core::odd?))
-(@define even? (@ Core::even?))
-
-(@define max (@ Core::max))
-(@define min (@ Core::min))
-
-(@define + (@ Core::+))
-(@define * (@ Core::*))
-(@define - (@ Core::-))
-(@define / (@ Core::/))
-
-(@define abs (@ Core::abs))
-
-(@define quotient (@ Core::quotient))
-(@define remainder (@ Core::remainder))
-(@define modulo (@ Core::modulo))
-
-(@define gcd (@ Core::gcd))
-(@define lcm (@ Core::lcm))
-
-;; (@define numerator (@ Core::numerator))
-;; (@define denominator (@ Core::denominator))
-
-(@define floor (@ Core::floor))
-(@define ceiling (@ Core::ceiling))
-(@define truncate (@ Core::truncate))
-(@define round (@ Core::round))
-
-;; (@define rationalize (@ Core::rationalize))
-
-(@define exp (@ Core::exp))
-(@define log (@ Core::log))
-(@define sin (@ Core::sin))
-(@define cos (@ Core::cos))
-(@define tan (@ Core::tan))
-(@define asin (@ Core::asin))
-(@define acos (@ Core::acos))
-(@define atan (@ Core::atan))
-
-(@define sqrt (@ Core::sqrt))
-(@define expt (@ Core::expt))
-
-(@define make-rectangular (@ Core::make-rectangular))
-(@define make-polar (@ Core::make-polar))
-(@define real-part (@ Core::real-part))
-(@define imag-part (@ Core::imag-part))
-(@define magnitude (@ Core::magnitude))
-(@define angle (@ Core::angle))
-
-(@define exact->inexact (@ Core::exact->inexact))
-(@define inexact->exact (@ Core::inexact->exact))
-
-(@define number->string (@ Core::number->string))
-(@define string->number (@ Core::string->number))
-
-;;; 6.3 Other data types
-
-;;;; 6.3.1 Booleans
-
-(@define not (@lambda (x) (@not x)))
-(@define boolean? (@ Core::boolean?))
-
-;;;; 6.3.2 Pairs and lists
-
-(@define pair? (@lambda (x) (@pair? x)))
-(@define cons (@lambda (x y) (@cons x y)))
-
-(@define car (@lambda (x) (@car x)))
-(@define cdr (@lambda (x) (@cdr x)))
-(@define set-car! (@ Core::set-car!))
-(@define set-cdr! (@ Core::set-cdr!))
-
-(@define caar (@lambda (x) (@caar x)))
-(@define cadr (@lambda (x) (@cadr x)))
-(@define cdar (@lambda (x) (@cdar x)))
-(@define cddr (@lambda (x) (@cddr x)))
-(@define caaar (@lambda (x) (@caaar x)))
-(@define caadr (@lambda (x) (@caadr x)))
-(@define cadar (@lambda (x) (@cadar x)))
-(@define caddr (@lambda (x) (@caddr x)))
-(@define cdaar (@lambda (x) (@cdaar x)))
-(@define cdadr (@lambda (x) (@cdadr x)))
-(@define cddar (@lambda (x) (@cddar x)))
-(@define cdddr (@lambda (x) (@cdddr x)))
-(@define caaaar (@lambda (x) (@caaaar x)))
-(@define caaadr (@lambda (x) (@caaadr x)))
-(@define caadar (@lambda (x) (@caadar x)))
-(@define caaddr (@lambda (x) (@caaddr x)))
-(@define cadaar (@lambda (x) (@cadaar x)))
-(@define cadadr (@lambda (x) (@cadadr x)))
-(@define caddar (@lambda (x) (@caddar x)))
-(@define cadddr (@lambda (x) (@cadddr x)))
-(@define cdaaar (@lambda (x) (@cdaaar x)))
-(@define cdaadr (@lambda (x) (@cdaadr x)))
-(@define cdadar (@lambda (x) (@cdadar x)))
-(@define cdaddr (@lambda (x) (@cdaddr x)))
-(@define cddaar (@lambda (x) (@cddaar x)))
-(@define cddadr (@lambda (x) (@cddadr x)))
-(@define cdddar (@lambda (x) (@cdddar x)))
-(@define cddddr (@lambda (x) (@cddddr x)))
-
-(@define null? (@lambda (x) (@null? x)))
-(@define list? (@lambda (x) (@list? x)))
-
-(@define list (@lambda x x))
-
-(@define length (@ Core::length))
-(@define append (@ Core::append))
-(@define reverse (@ Core::reverse))
-(@define list-tail (@ Core::list-tail))
-(@define list-ref (@ Core::list-ref))
-
-(@define memq (@ Core::memq))
-(@define memv (@ Core::memv))
-(@define member (@ Core::member))
-
-(@define assq (@ Core::assq))
-(@define assv (@ Core::assv))
-(@define assoc (@ Core::assoc))
-
-;;;; 6.3.3 Symbols
-
-(@define symbol? (@ Core::symbol?))
-(@define symbol->string (@ Core::symbol->string))
-(@define string->symbol (@ Core::string->symbol))
-
-;;;; 6.3.4 Characters
-
-(@define char? (@ Core::char?))
-(@define char=? (@ Core::char=?))
-(@define char<? (@ Core::char<?))
-(@define char>? (@ Core::char>?))
-(@define char<=? (@ Core::char<=?))
-(@define char>=? (@ Core::char>=?))
-(@define char-ci=? (@ Core::char-ci=?))
-(@define char-ci<? (@ Core::char-ci<?))
-(@define char-ci>? (@ Core::char-ci>?))
-(@define char-ci<=? (@ Core::char-ci<=?))
-(@define char-ci>=? (@ Core::char-ci>=?))
-(@define char-alphabetic? (@ Core::char-alphabetic?))
-(@define char-numeric? (@ Core::char-numeric?))
-(@define char-whitespace? (@ Core::char-whitespace?))
-(@define char-upper-case? (@ Core::char-upper-case?))
-(@define char-lower-case? (@ Core::char-lower-case?))
-(@define char->integer (@ Core::char->integer))
-(@define integer->char (@ Core::integer->char))
-(@define char-upcase (@ Core::char-upcase))
-(@define char-downcase (@ Core::char-downcase))
-
-;;;; 6.3.5 Strings
-
-(@define string? (@ Core::string?))
-(@define make-string (@ Core::make-string))
-(@define string (@ Core::string))
-(@define string-length (@ Core::string-length))
-(@define string-ref (@ Core::string-ref))
-(@define string-set! (@ Core::string-set!))
-
-(@define string=? (@ Core::string=?))
-(@define string-ci=? (@ Core::string-ci=?))
-(@define string<? (@ Core::string<?))
-(@define string>? (@ Core::string>?))
-(@define string<=? (@ Core::string<=?))
-(@define string>=? (@ Core::string>=?))
-(@define string-ci<? (@ Core::string-ci<?))
-(@define string-ci>? (@ Core::string-ci>?))
-(@define string-ci<=? (@ Core::string-ci<=?))
-(@define string-ci>=? (@ Core::string-ci>=?))
-
-(@define substring (@ Core::substring))
-(@define string-append (@ Core::string-append))
-(@define string->list (@ Core::string->list))
-(@define list->string (@ Core::list->string))
-(@define string-copy (@ Core::string-copy))
-(@define string-fill! (@ Core::string-fill!))
-
-;;;; 6.3.6 Vectors
-
-(@define vector? (@ Core::vector?))
-(@define make-vector (@ Core::make-vector))
-(@define vector (@ Core::vector))
-(@define vector-length (@ Core::vector-length))
-(@define vector-ref (@ Core::vector-ref))
-(@define vector-set! (@ Core::vector-set!))
-(@define vector->list (@ Core::vector->list))
-(@define list->vector (@ Core::list->vector))
-(@define vector-fill! (@ Core::vector-fill!))
-
-;;; 6.4 Control features
-
-(@define procedure? (@ Core::procedure?))
-(@define apply (@ Core::apply))
-(@define map (@ Core::map))
-(@define for-each (@ Core::for-each))
-(@define force (@ Core::force))
-
-(@define call-with-current-continuation (@ Core::call-with-current-continuation))
-(@define values (@ Core::values))
-(@define call-with-values (@ Core::call-with-values))
-(@define dynamic-wind (@ Core::dynamic-wind))
-
-;;; 6.5 Eval
-
-(@define eval
- (@let ((l (@ Language::r5rs::spec::r5rs)))
- (@lambda (x e)
- (((@ System::Base::language::compile-in) x e l)))))
-
-;; (@define scheme-report-environment
-;; (@lambda (version)
-;; (@if (@= version 5)
-;; (@ Language::R5RS::Core)
-;; (@error "Unsupported environment version" version))))
-;;
-;; (@define null-environment
-;; (@lambda (version)
-;; (@if (@= version 5)
-;; (@ Language::R5RS::Null)
-;; (@error "Unsupported environment version" version))))
-
-(@define interaction-environment (@lambda () (@current-module)))
-
-;;; 6.6 Input and output
-
-;;;; 6.6.1 Ports
-
-(@define call-with-input-file (@ Core::call-with-input-file))
-(@define call-with-output-file (@ Core::call-with-output-file))
-
-(@define input-port? (@ Core::input-port?))
-(@define output-port? (@ Core::output-port?))
-(@define current-input-port (@ Core::current-input-port))
-(@define current-output-port (@ Core::current-output-port))
-
-(@define with-input-from-file (@ Core::with-input-from-file))
-(@define with-output-to-file (@ Core::with-output-to-file))
-
-(@define open-input-file (@ Core::open-input-file))
-(@define open-output-file (@ Core::open-output-file))
-(@define close-input-port (@ Core::close-input-port))
-(@define close-output-port (@ Core::close-output-port))
-
-;;;; 6.6.2 Input
-
-(@define read (@ Core::read))
-(@define read-char (@ Core::read-char))
-(@define peek-char (@ Core::peek-char))
-(@define eof-object? (@ Core::eof-object?))
-(@define char-ready? (@ Core::char-ready?))
-
-;;;; 6.6.3 Output
-
-(@define write (@ Core::write))
-(@define display (@ Core::display))
-(@define newline (@ Core::newline))
-(@define write-char (@ Core::write-char))
-
-;;;; 6.6.4 System interface
-
-(@define load
- (@lambda (file)
- (call-with-input-file file
- (@lambda (port)
- (@let ((loop (@lambda (x)
- (@if (@not (eof-object? x))
- (@begin
- (eval x (interaction-environment))
- (loop (read port)))))))
- (loop (read port)))))))
-
-;; transcript-on
-;; transcript-off
+++ /dev/null
-;;; R5RS syntax expander
-
-;; Copyright (C) 2001 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
-
-;;; Code:
-
-(define-module (language r5rs expand)
- #:export (expand void
- identifier? free-identifier=? bound-identifier=?
- generate-temporaries datum->syntax-object syntax-object->datum))
-
-(define sc-expand #f)
-(define $sc-put-cte #f)
-(define $syntax-dispatch #f)
-(define syntax-rules #f)
-(define syntax-error #f)
-(define identifier? #f)
-(define free-identifier=? #f)
-(define bound-identifier=? #f)
-(define generate-temporaries #f)
-(define datum->syntax-object #f)
-(define syntax-object->datum #f)
-
-(define void (lambda () (if #f #f)))
-
-(define andmap
- (lambda (f first . rest)
- (or (null? first)
- (if (null? rest)
- (let andmap ((first first))
- (let ((x (car first)) (first (cdr first)))
- (if (null? first)
- (f x)
- (and (f x) (andmap first)))))
- (let andmap ((first first) (rest rest))
- (let ((x (car first))
- (xr (map car rest))
- (first (cdr first))
- (rest (map cdr rest)))
- (if (null? first)
- (apply f (cons x xr))
- (and (apply f (cons x xr)) (andmap first rest)))))))))
-
-(define ormap
- (lambda (proc list1)
- (and (not (null? list1))
- (or (proc (car list1)) (ormap proc (cdr list1))))))
-
-(define putprop set-symbol-property!)
-(define getprop symbol-property)
-(define remprop symbol-property-remove!)
-
-(define syncase-module (current-module))
-(define guile-eval eval)
-(define (eval x)
- (if (and (pair? x) (equal? (car x) "noexpand"))
- (cdr x)
- (guile-eval x syncase-module)))
-
-(define guile-error error)
-(define (error who format-string why what)
- (guile-error why what))
-
-(load "psyntax.pp")
-
-(define expand sc-expand)
+++ /dev/null
-;;; psyntax.pp
-;;; automatically generated from psyntax.ss
-;;; Wed Aug 30 12:24:52 EST 2000
-;;; see copyright notice in psyntax.ss
-
-((lambda ()
- (letrec ((g452
- (lambda (g1823)
- ((letrec ((g1824
- (lambda (g1827 g1825 g1826)
- (if (pair? g1827)
- (g1824
- (cdr g1827)
- (cons (g393 (car g1827) g1826) g1825)
- g1826)
- (if (g256 g1827)
- (cons (g393 g1827 g1826) g1825)
- (if (null? g1827)
- g1825
- (if (g204 g1827)
- (g1824
- (g205 g1827)
- g1825
- (g371 g1826 (g206 g1827)))
- (if (g90 g1827)
- (g1824
- (annotation-expression
- g1827)
- g1825
- g1826)
- (cons g1827 g1825)))))))))
- g1824)
- g1823
- '()
- '(()))))
- (g451
- (lambda (g833)
- ((lambda (g834) (if (g90 g834) (gensym) (gensym)))
- (if (g204 g833) (g205 g833) g833))))
- (g450
- (lambda (g1820 g1819)
- (g449 g1820
- g1819
- (lambda (g1821)
- (if ((lambda (g1822)
- (if g1822
- g1822
- (if (pair? g1821)
- (g90 (car g1821))
- '#f)))
- (g90 g1821))
- (g448 g1821 '#f)
- g1821)))))
- (g449
- (lambda (g837 g835 g836)
- (if (memq 'top (g264 g835))
- (g836 g837)
- ((letrec ((g838
- (lambda (g839)
- (if (g204 g839)
- (g449 (g205 g839) (g206 g839) g836)
- (if (pair? g839)
- ((lambda (g841 g840)
- (if (if (eq? g841 (car g839))
- (eq? g840 (cdr g839))
- '#f)
- g839
- (cons g841 g840)))
- (g838 (car g839))
- (g838 (cdr g839)))
- (if (vector? g839)
- ((lambda (g842)
- ((lambda (g843)
- (if (andmap
- eq?
- g842
- g843)
- g839
- (list->vector g843)))
- (map g838 g842)))
- (vector->list g839))
- g839))))))
- g838)
- g837))))
- (g448
- (lambda (g1813 g1812)
- (if (pair? g1813)
- ((lambda (g1814)
- (begin (if g1812
- (set-annotation-stripped! g1812 g1814)
- (void))
- (set-car! g1814 (g448 (car g1813) '#f))
- (set-cdr! g1814 (g448 (cdr g1813) '#f))
- g1814))
- (cons '#f '#f))
- (if (g90 g1813)
- ((lambda (g1815)
- (if g1815
- g1815
- (g448 (annotation-expression g1813) g1813)))
- (annotation-stripped g1813))
- (if (vector? g1813)
- ((lambda (g1816)
- (begin (if g1812
- (set-annotation-stripped!
- g1812
- g1816)
- (void))
- ((letrec ((g1817
- (lambda (g1818)
- (if (not (< g1818 '0))
- (begin (vector-set!
- g1816
- g1818
- (g448 (vector-ref
- g1813
- g1818)
- '#f))
- (g1817
- (- g1818
- '1)))
- (void)))))
- g1817)
- (- (vector-length g1813) '1))
- g1816))
- (make-vector (vector-length g1813)))
- g1813)))))
- (g447
- (lambda (g844)
- (if (g255 g844)
- (g378 g844
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage ((import-token . *top*)) () ())
- #(ribcage ((import-token . *top*)) () ()))))
- '#f)))
- (g446 (lambda () (list 'void)))
- (g445
- (lambda (g850 g845 g849 g846 g848 g847)
- ((lambda (g851)
- ((lambda (g852)
- (if g852
- (apply
- (lambda (g857 g853 g856 g854 g855)
- ((lambda (g858)
- (if (not (g389 g858))
- (g391 (map (lambda (g859)
- (g393 g859 g846))
- g858)
- (g394 g845 g846 g848)
- '"keyword")
- ((lambda (g860)
- ((lambda (g861)
- (g847 (cons g854 g855)
- (g247 g860
- ((lambda (g863 g862)
- (map (lambda (g865)
- (g231 'deferred
- (g432 g865
- g862
- g863)))
- g856))
- (if g850 g861 g846)
- (g249 g849))
- g849)
- g861
- g848))
- (g368 g858 g860 g846)))
- (g299 g858))))
- g853))
- g852)
- ((lambda (g868)
- (syntax-error (g394 g845 g846 g848)))
- g851)))
- ($syntax-dispatch
- g851
- '(any #(each (any any)) any . each-any))))
- g845)))
- (g444
- (lambda (g1789 g1785 g1788 g1786 g1787)
- ((lambda (g1790)
- ((lambda (g1791)
- (if g1791
- (apply
- (lambda (g1794 g1792 g1793)
- ((lambda (g1795)
- (if (not (g389 g1795))
- (syntax-error
- g1789
- '"invalid parameter list in")
- ((lambda (g1797 g1796)
- (g1787
- g1796
- (g437 (cons g1792 g1793)
- g1789
- (g248 g1797 g1796 g1788)
- (g368 g1795 g1797 g1786))))
- (g299 g1795)
- (map g451 g1795))))
- g1794))
- g1791)
- ((lambda (g1800)
- (if g1800
- (apply
- (lambda (g1803 g1801 g1802)
- ((lambda (g1804)
- (if (not (g389 g1804))
- (syntax-error
- g1789
- '"invalid parameter list in")
- ((lambda (g1806 g1805)
- (g1787
- ((letrec ((g1808
- (lambda (g1810
- g1809)
- (if (null?
- g1810)
- g1809
- (g1808
- (cdr g1810)
- (cons (car g1810)
- g1809))))))
- g1808)
- (cdr g1805)
- (car g1805))
- (g437 (cons g1801 g1802)
- g1789
- (g248 g1806
- g1805
- g1788)
- (g368 g1804
- g1806
- g1786))))
- (g299 g1804)
- (map g451 g1804))))
- (g452 g1803)))
- g1800)
- ((lambda (g1811) (syntax-error g1789))
- g1790)))
- ($syntax-dispatch g1790 '(any any . each-any)))))
- ($syntax-dispatch g1790 '(each-any any . each-any))))
- g1785)))
- (g443
- (lambda (g872 g869 g871 g870)
- ((lambda (g873)
- ((lambda (g874)
- (if (if g874
- (apply
- (lambda (g877 g875 g876) (g256 g875))
- g874)
- '#f)
- (apply
- (lambda (g880 g878 g879) (g870 g878 g879 g869))
- g874)
- ((lambda (g881)
- (syntax-error (g394 g872 g869 g871)))
- g873)))
- ($syntax-dispatch g873 '(any any any))))
- g872)))
- (g442
- (lambda (g1758 g1755 g1757 g1756)
- ((lambda (g1759)
- ((lambda (g1760)
- (if (if g1760
- (apply
- (lambda (g1763 g1761 g1762) (g256 g1761))
- g1760)
- '#f)
- (apply
- (lambda (g1766 g1764 g1765)
- (g1756 g1764 g1765 g1755))
- g1760)
- ((lambda (g1767)
- (if (if g1767
- (apply
- (lambda (g1772
- g1768
- g1771
- g1769
- g1770)
- (if (g256 g1768)
- (g389 (g452 g1771))
- '#f))
- g1767)
- '#f)
- (apply
- (lambda (g1777 g1773 g1776 g1774 g1775)
- (g1756
- (g393 g1773 g1755)
- (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ name args e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(e w s k)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (g393 (cons g1776
- (cons g1774 g1775))
- g1755))
- '(())))
- g1767)
- ((lambda (g1779)
- (if (if g1779
- (apply
- (lambda (g1781 g1780)
- (g256 g1780))
- g1779)
- '#f)
- (apply
- (lambda (g1783 g1782)
- (g1756
- (g393 g1782 g1755)
- '(#(syntax-object
- void
- ((top)
- #(ribcage
- #(_ name)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(e w s k)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- '(())))
- g1779)
- ((lambda (g1784)
- (syntax-error
- (g394 g1758 g1755 g1757)))
- g1759)))
- ($syntax-dispatch g1759 '(any any)))))
- ($syntax-dispatch
- g1759
- '(any (any . any) any . each-any)))))
- ($syntax-dispatch g1759 '(any any any))))
- g1758)))
- (g441
- (lambda (g885 g882 g884 g883)
- ((lambda (g886)
- ((lambda (g887)
- (if (if g887
- (apply (lambda (g889 g888) (g256 g888)) g887)
- '#f)
- (apply
- (lambda (g891 g890) (g883 (g393 g890 g882)))
- g887)
- ((lambda (g892)
- (syntax-error (g394 g885 g882 g884)))
- g886)))
- ($syntax-dispatch g886 '(any any))))
- g885)))
- (g440
- (lambda (g1723 g1719 g1722 g1720 g1721)
- (letrec ((g1725
- (lambda (g1753 g1751 g1752)
- (g1721
- g1753
- (g1724 g1751)
- (map (lambda (g1754) (g393 g1754 g1720))
- g1752))))
- (g1724
- (lambda (g1745)
- (if (null? g1745)
- '()
- (cons ((lambda (g1746)
- ((lambda (g1747)
- (if g1747
- (apply
- (lambda (g1748)
- (g1724 g1748))
- g1747)
- ((lambda (g1750)
- (if (g256 g1750)
- (g393 g1750 g1720)
- (syntax-error
- (g394 g1723
- g1719
- g1722)
- '"invalid exports list in")))
- g1746)))
- ($syntax-dispatch
- g1746
- 'each-any)))
- (car g1745))
- (g1724 (cdr g1745)))))))
- ((lambda (g1726)
- ((lambda (g1727)
- (if g1727
- (apply
- (lambda (g1730 g1728 g1729)
- (g1725 '#f g1728 g1729))
- g1727)
- ((lambda (g1733)
- (if (if g1733
- (apply
- (lambda (g1737 g1734 g1736 g1735)
- (g256 g1734))
- g1733)
- '#f)
- (apply
- (lambda (g1741 g1738 g1740 g1739)
- (g1725
- (g393 g1738 g1719)
- g1740
- g1739))
- g1733)
- ((lambda (g1744)
- (syntax-error
- (g394 g1723 g1719 g1722)))
- g1726)))
- ($syntax-dispatch
- g1726
- '(any any each-any . each-any)))))
- ($syntax-dispatch g1726 '(any each-any . each-any))))
- g1723))))
- (g439
- (lambda (g894 g893)
- ((lambda (g895)
- (if g895
- (g366 g893 g895)
- (g429 (lambda (g896)
- ((lambda (g897)
- (begin (if (not g897)
- (syntax-error
- g896
- '"exported identifier not visible")
- (void))
- (g363 g893 g896 g897)))
- (g376 g896 '(()))))
- (g404 g894))))
- (g405 g894))))
- (g438
- (lambda (g1652 g1648 g1651 g1649 g1650)
- (letrec ((g1653
- (lambda (g1718 g1714 g1717 g1715 g1716)
- (begin (g426 g1648 g1714)
- (g1650 g1718 g1714 g1717 g1715 g1716)))))
- ((letrec ((g1654
- (lambda (g1659 g1655 g1658 g1656 g1657)
- (if (null? g1659)
- (g1653 g1659 g1655 g1658 g1656 g1657)
- ((lambda (g1661 g1660)
- (call-with-values
- (lambda ()
- (g398 g1661
- g1660
- '(())
- '#f
- g1652))
- (lambda (g1666
- g1662
- g1665
- g1663
- g1664)
- ((lambda (g1667)
- (if (memv g1667 '(define-form))
- (g442 g1665
- g1663
- g1664
- (lambda (g1670
- g1668
- g1669)
- ((lambda (g1672
- g1671)
- ((lambda (g1673)
- (begin (g363 g1652
- g1672
- g1671)
- (g424 g1649
- g1671
- (g231 'lexical
- g1673))
- (g1654
- (cdr g1659)
- (cons g1672
- g1655)
- (cons g1673
- g1658)
- (cons (cons g1660
- (g393 g1668
- g1669))
- g1656)
- g1657)))
- (g451 g1672)))
- (g393 g1670 g1669)
- (g297))))
- (if (memv g1667
- '(define-syntax-form))
- (g443 g1665
- g1663
- g1664
- (lambda (g1676
- g1674
- g1675)
- ((lambda (g1679
- g1677
- g1678)
- (begin (g363 g1652
- g1679
- g1677)
- (g424 g1649
- g1677
- (g231 'deferred
- g1678))
- (g1654
- (cdr g1659)
- (cons g1679
- g1655)
- g1658
- g1656
- g1657)))
- (g393 g1676
- g1675)
- (g297)
- (g432 g1674
- (g249 g1660)
- g1675))))
- (if (memv g1667
- '(module-form))
- ((lambda (g1680)
- ((lambda (g1681)
- ((lambda ()
- (g440 g1665
- g1663
- g1664
- g1681
- (lambda (g1684
- g1682
- g1683)
- (g438 g1680
- (g394 g1665
- g1663
- g1664)
- (map (lambda (g1695)
- (cons g1660
- g1695))
- g1683)
- g1649
- (lambda (g1689
- g1685
- g1688
- g1686
- g1687)
- (begin (g425 g1648
- (g401 g1682)
- g1685)
- ((lambda (g1693
- g1690
- g1692
- g1691)
- (if g1684
- ((lambda (g1694)
- (begin (g363 g1652
- g1684
- g1694)
- (g424 g1649
- g1694
- (g231 'module
- g1693))
- (g1654
- (cdr g1659)
- (cons g1684
- g1655)
- g1690
- g1692
- g1691)))
- (g297))
- ((lambda ()
- (begin (g439 g1693
- g1652)
- (g1654
- (cdr g1659)
- (cons g1693
- g1655)
- g1690
- g1692
- g1691))))))
- (g408 g1682)
- (append
- g1688
- g1658)
- (append
- g1686
- g1656)
- (append
- g1657
- g1687
- g1689))))))))))
- (g263 (g264 g1663)
- (cons g1680
- (g265 g1663)))))
- (g304 '()
- '()
- '()))
- (if (memv g1667
- '(import-form))
- (g441 g1665
- g1663
- g1664
- (lambda (g1696)
- ((lambda (g1697)
- ((lambda (g1698)
- ((lambda (g1699)
- (if (memv g1699
- '(module))
- ((lambda (g1700)
- (begin (if g1662
- (g364 g1652
- g1662)
- (void))
- (g439 g1700
- g1652)
- (g1654
- (cdr g1659)
- (cons g1700
- g1655)
- g1658
- g1656
- g1657)))
- (cdr g1698))
- (if (memv g1699
- '(displaced-lexical))
- (g250 g1696)
- (syntax-error
- g1696
- '"import from unknown module"))))
- (car g1698)))
- (g253 g1697
- g1649)))
- (g377 g1696
- '(())))))
- (if (memv g1667
- '(begin-form))
- ((lambda (g1701)
- ((lambda (g1702)
- (if g1702
- (apply
- (lambda (g1704
- g1703)
- (g1654
- ((letrec ((g1705
- (lambda (g1706)
- (if (null?
- g1706)
- (cdr g1659)
- (cons (cons g1660
- (g393 (car g1706)
- g1663))
- (g1705
- (cdr g1706)))))))
- g1705)
- g1703)
- g1655
- g1658
- g1656
- g1657))
- g1702)
- (syntax-error
- g1701)))
- ($syntax-dispatch
- g1701
- '(any .
- each-any))))
- g1665)
- (if (memv g1667
- '(local-syntax-form))
- (g445 g1662
- g1665
- g1660
- g1663
- g1664
- (lambda (g1711
- g1708
- g1710
- g1709)
- (g1654
- ((letrec ((g1712
- (lambda (g1713)
- (if (null?
- g1713)
- (cdr g1659)
- (cons (cons g1708
- (g393 (car g1713)
- g1710))
- (g1712
- (cdr g1713)))))))
- g1712)
- g1711)
- g1655
- g1658
- g1656
- g1657)))
- (g1653
- (cons (cons g1660
- (g394 g1665
- g1663
- g1664))
- (cdr g1659))
- g1655
- g1658
- g1656
- g1657))))))))
- g1666))))
- (cdar g1659)
- (caar g1659))))))
- g1654)
- g1651
- '()
- '()
- '()
- '()))))
- (g437
- (lambda (g901 g898 g900 g899)
- ((lambda (g902)
- ((lambda (g903)
- ((lambda (g904)
- ((lambda (g905)
- ((lambda ()
- (g438 g903
- g898
- g905
- g902
- (lambda (g910 g906 g909 g907 g908)
- (begin (if (null? g910)
- (syntax-error
- g898
- '"no expressions in body")
- (void))
- (g191 '#f
- g909
- (map (lambda (g912)
- (g432 (cdr g912)
- (car g912)
- '(())))
- g907)
- (g190 '#f
- (map (lambda (g911)
- (g432 (cdr g911)
- (car g911)
- '(())))
- (append
- g908
- g910))))))))))
- (map (lambda (g913) (cons g902 (g393 g913 g904)))
- g901)))
- (g263 (g264 g899) (cons g903 (g265 g899)))))
- (g304 '() '() '())))
- (cons '("placeholder" placeholder) g900))))
- (g436
- (lambda (g1635 g1630 g1634 g1631 g1633 g1632)
- (letrec ((g1636
- (lambda (g1640 g1639)
- (if (pair? g1640)
- (cons (g1636 (car g1640) g1639)
- (g1636 (cdr g1640) g1639))
- (if (g204 g1640)
- ((lambda (g1641)
- ((lambda (g1643 g1642)
- (g203 (g205 g1640)
- (if (if (pair? g1643)
- (eq? (car g1643)
- '#f)
- '#f)
- (g263 (cdr g1643)
- (if g1632
- (cons g1632
- (cdr g1642))
- (cdr g1642)))
- (g263 (cons g1639 g1643)
- (if g1632
- (cons g1632
- (cons 'shift
- g1642))
- (cons 'shift
- g1642))))))
- (g264 g1641)
- (g265 g1641)))
- (g206 g1640))
- (if (vector? g1640)
- ((lambda (g1644)
- ((lambda (g1645)
- ((lambda ()
- ((letrec ((g1646
- (lambda (g1647)
- (if (= g1647
- g1644)
- g1645
- (begin (vector-set!
- g1645
- g1647
- (g1636
- (vector-ref
- g1640
- g1647)
- g1639))
- (g1646
- (+ g1647
- '1)))))))
- g1646)
- '0))))
- (make-vector g1644)))
- (vector-length g1640))
- (if (symbol? g1640)
- (syntax-error
- (g394 g1630 g1631 g1633)
- '"encountered raw symbol "
- (format '"~s" g1640)
- '" in output of macro")
- g1640)))))))
- (g1636
- ((lambda (g1637)
- (if (procedure? g1637)
- (g1637
- (lambda (g1638)
- (begin (if (not (identifier? g1638))
- (syntax-error
- g1638
- '"environment argument is not an identifier")
- (void))
- (g253 (g377 g1638 '(())) g1634))))
- g1637))
- (g1635 (g394 g1630 (g349 g1631) g1633)))
- (string '#\m)))))
- (g435
- (lambda (g918 g914 g917 g915 g916)
- ((lambda (g919)
- ((lambda (g920)
- (if (if g920
- (apply
- (lambda (g923 g921 g922) (g256 g921))
- g920)
- '#f)
- (apply
- (lambda (g926 g924 g925)
- ((lambda (g927)
- ((lambda (g928)
- ((lambda (g929)
- (if (memv g929 '(macro!))
- ((lambda (g931 g930)
- (g398 (g436 (g233 g928)
- (list '#(syntax-object
- set!
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(id
- val)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(t)
- #(("m" top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(b)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(n)
- #((top))
- #("i"))
- #(ribcage
- #(_
- id
- val)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- r
- w
- s
- rib)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g931
- g930)
- g914
- '(())
- g915
- g916)
- g914
- '(())
- g915
- g916))
- (g393 g924 g917)
- (g393 g925 g917))
- (values
- 'core
- (lambda (g935 g932 g934 g933)
- ((lambda (g937 g936)
- ((lambda (g938)
- ((lambda (g939)
- (if (memv g939
- '(lexical))
- (list 'set!
- (g233 g938)
- g937)
- (if (memv g939
- '(global))
- (list 'set!
- (g233 g938)
- g937)
- (if (memv g939
- '(displaced-lexical))
- (syntax-error
- (g393 g924
- g934)
- '"identifier out of context")
- (syntax-error
- (g394 g935
- g934
- g933))))))
- (g232 g938)))
- (g253 g936 g932)))
- (g432 g925 g932 g934)
- (g377 g924 g934)))
- g918
- g917
- g915)))
- (g232 g928)))
- (g253 g927 g914)))
- (g377 g924 g917)))
- g920)
- ((lambda (g940)
- (syntax-error (g394 g918 g917 g915)))
- g919)))
- ($syntax-dispatch g919 '(any any any))))
- g918)))
- (g434
- (lambda (g1622 g1618 g1621 g1619 g1620)
- ((lambda (g1623)
- ((lambda (g1624)
- (if g1624
- (apply
- (lambda (g1626 g1625)
- (cons g1622
- (map (lambda (g1628)
- (g432 g1628 g1621 g1619))
- g1625)))
- g1624)
- ((lambda (g1629)
- (syntax-error (g394 g1618 g1619 g1620)))
- g1623)))
- ($syntax-dispatch g1623 '(any . each-any))))
- g1618)))
- (g433
- (lambda (g946 g941 g945 g942 g944 g943)
- ((lambda (g947)
- (if (memv g947 '(lexical))
- g941
- (if (memv g947 '(core))
- (g941 g945 g942 g944 g943)
- (if (memv g947 '(lexical-call))
- (g434 g941 g945 g942 g944 g943)
- (if (memv g947 '(constant))
- (list 'quote
- (g450 (g394 g945 g944 g943) '(())))
- (if (memv g947 '(global))
- g941
- (if (memv g947 '(call))
- (g434 (g432 (car g945) g942 g944)
- g945
- g942
- g944
- g943)
- (if (memv g947 '(begin-form))
- ((lambda (g948)
- ((lambda (g949)
- (if g949
- (apply
- (lambda (g952
- g950
- g951)
- (g395 (cons g950
- g951)
- g942
- g944
- g943))
- g949)
- (syntax-error
- g948)))
- ($syntax-dispatch
- g948
- '(any any
- .
- each-any))))
- g945)
- (if (memv g947
- '(local-syntax-form))
- (g445 g941
- g945
- g942
- g944
- g943
- g395)
- (if (memv g947
- '(eval-when-form))
- ((lambda (g954)
- ((lambda (g955)
- (if g955
- (apply
- (lambda (g959
- g956
- g958
- g957)
- ((lambda (g960)
- (if (memq 'eval
- g960)
- (g395 (cons g958
- g957)
- g942
- g944
- g943)
- (g446)))
- (g397 g945
- g956
- g944)))
- g955)
- (syntax-error
- g954)))
- ($syntax-dispatch
- g954
- '(any each-any
- any
- .
- each-any))))
- g945)
- (if (memv g947
- '(define-form
- define-syntax-form
- module-form
- import-form))
- (syntax-error
- (g394 g945
- g944
- g943)
- '"invalid context for definition")
- (if (memv g947
- '(syntax))
- (syntax-error
- (g394 g945
- g944
- g943)
- '"reference to pattern variable outside syntax form")
- (if (memv g947
- '(displaced-lexical))
- (g250 (g394 g945
- g944
- g943))
- (syntax-error
- (g394 g945
- g944
- g943)))))))))))))))
- g946)))
- (g432
- (lambda (g1612 g1610 g1611)
- (call-with-values
- (lambda () (g398 g1612 g1610 g1611 '#f '#f))
- (lambda (g1617 g1613 g1616 g1614 g1615)
- (g433 g1617 g1613 g1616 g1610 g1614 g1615)))))
- (g431
- (lambda (g965 g963 g964)
- ((lambda (g966)
- (if (memv g966 '(c))
- (if (memq 'compile g963)
- ((lambda (g967)
- (begin (g91 g967)
- (if (memq 'load g963) g967 (g446))))
- (g964))
- (if (memq 'load g963) (g964) (g446)))
- (if (memv g966 '(c&e))
- ((lambda (g968) (begin (g91 g968) g968)) (g964))
- (begin (if (memq 'eval g963) (g91 (g964)) (void))
- (g446)))))
- g965)))
- (g430
- (lambda (g1609 g1608)
- (list '$sc-put-cte
- (list 'quote g1609)
- (list 'quote (g231 'do-import g1608)))))
- (g429
- (lambda (g970 g969)
- ((lambda (g971)
- ((letrec ((g972
- (lambda (g973)
- (if (not (= g973 g971))
- (begin (g970 (vector-ref g969 g973))
- (g972 (+ g973 '1)))
- (void)))))
- g972)
- '0))
- (vector-length g969))))
- (g428
- (lambda (g1604 g1603)
- ((letrec ((g1605
- (lambda (g1607 g1606)
- (if (< g1607 '0)
- g1606
- (g1605
- (- g1607 '1)
- (cons (g1604 (vector-ref g1603 g1607))
- g1606))))))
- g1605)
- (- (vector-length g1603) '1)
- '())))
- (g427
- (lambda (g982 g974 g981 g975 g980 g976 g979 g977 g978)
- (letrec ((g985
- (lambda (g1050 g1049)
- ((lambda (g1051)
- (map (lambda (g1052)
- ((lambda (g1053)
- (if (not (g392 g1053 g1051))
- g1052
- (g410 (g412 g1052)
- g1053
- (g414 g1052)
- (append
- (g984 g1053)
- (g415 g1052))
- (g416 g1052))))
- (g413 g1052)))
- g1050))
- (map (lambda (g1054)
- (if (pair? g1054) (car g1054) g1054))
- g1049))))
- (g984
- (lambda (g1043)
- ((letrec ((g1044
- (lambda (g1045)
- (if (null? g1045)
- '()
- (if (if (pair? (car g1045))
- (g388 g1043
- (caar g1045))
- '#f)
- (g401 (cdar g1045))
- (g1044 (cdr g1045)))))))
- g1044)
- g980)))
- (g983
- (lambda (g1048 g1046 g1047)
- (begin (g426 g974 g1046)
- (g425 g974 g976 g1046)
- (g978 g1048 g1047)))))
- ((letrec ((g986
- (lambda (g990 g987 g989 g988)
- (if (null? g990)
- (g983 g989 g987 g988)
- ((lambda (g992 g991)
- (call-with-values
- (lambda ()
- (g398 g992 g991 '(()) '#f g982))
- (lambda (g997 g993 g996 g994 g995)
- ((lambda (g998)
- (if (memv g998 '(define-form))
- (g442 g996
- g994
- g995
- (lambda (g1001
- g999
- g1000)
- ((lambda (g1002)
- ((lambda (g1003)
- ((lambda (g1004)
- ((lambda ()
- (begin (g363 g982
- g1002
- g1003)
- (g986 (cdr g990)
- (cons g1002
- g987)
- (cons (g410 g997
- g1002
- g1003
- g1004
- (cons g991
- (g393 g999
- g1000)))
- g989)
- g988)))))
- (g984 g1002)))
- (g300)))
- (g393 g1001
- g1000))))
- (if (memv g998
- '(define-syntax-form))
- (g443 g996
- g994
- g995
- (lambda (g1007
- g1005
- g1006)
- ((lambda (g1008)
- ((lambda (g1009)
- ((lambda (g1010)
- ((lambda (g1011)
- ((lambda ()
- (begin (g424 g975
- (g302 g1009)
- (cons 'deferred
- g1011))
- (g363 g982
- g1008
- g1009)
- (g986 (cdr g990)
- (cons g1008
- g987)
- (cons (g410 g997
- g1008
- g1009
- g1010
- g1011)
- g989)
- g988)))))
- (g432 g1005
- (g249 g991)
- g1006)))
- (g984 g1008)))
- (g300)))
- (g393 g1007
- g1006))))
- (if (memv g998
- '(module-form))
- ((lambda (g1012)
- ((lambda (g1013)
- ((lambda ()
- (g440 g996
- g994
- g995
- g1013
- (lambda (g1016
- g1014
- g1015)
- (g427 g1012
- (g394 g996
- g994
- g995)
- (map (lambda (g1024)
- (cons g991
- g1024))
- g1015)
- g975
- g1014
- (g401 g1014)
- g979
- g977
- (lambda (g1018
- g1017)
- ((lambda (g1019)
- ((lambda (g1020)
- ((lambda (g1021)
- ((lambda ()
- (if g1016
- ((lambda (g1023
- g1022)
- (begin (g424 g975
- (g302 g1023)
- (g231 'module
- g1019))
- (g363 g982
- g1016
- g1023)
- (g986 (cdr g990)
- (cons g1016
- g987)
- (cons (g410 g997
- g1016
- g1023
- g1022
- g1014)
- g1020)
- g1021)))
- (g300)
- (g984 g1016))
- ((lambda ()
- (begin (g439 g1019
- g982)
- (g986 (cdr g990)
- (cons g1019
- g987)
- g1020
- g1021))))))))
- (append
- g988
- g1017)))
- (append
- (if g1016
- g1018
- (g985 g1018
- g1014))
- g989)))
- (g408 g1014)))))))))
- (g263 (g264 g994)
- (cons g1012
- (g265 g994)))))
- (g304 '()
- '()
- '()))
- (if (memv g998
- '(import-form))
- (g441 g996
- g994
- g995
- (lambda (g1025)
- ((lambda (g1026)
- ((lambda (g1027)
- ((lambda (g1028)
- (if (memv g1028
- '(module))
- ((lambda (g1029)
- (begin (if g993
- (g364 g982
- g993)
- (void))
- (g439 g1029
- g982)
- (g986 (cdr g990)
- (cons g1029
- g987)
- (g985 g989
- (vector->list
- (g404 g1029)))
- g988)))
- (g233 g1027))
- (if (memv g1028
- '(displaced-lexical))
- (g250 g1025)
- (syntax-error
- g1025
- '"import from unknown module"))))
- (g232 g1027)))
- (g253 g1026
- g975)))
- (g377 g1025
- '(())))))
- (if (memv g998
- '(begin-form))
- ((lambda (g1030)
- ((lambda (g1031)
- (if g1031
- (apply
- (lambda (g1033
- g1032)
- (g986 ((letrec ((g1034
- (lambda (g1035)
- (if (null?
- g1035)
- (cdr g990)
- (cons (cons g991
- (g393 (car g1035)
- g994))
- (g1034
- (cdr g1035)))))))
- g1034)
- g1032)
- g987
- g989
- g988))
- g1031)
- (syntax-error
- g1030)))
- ($syntax-dispatch
- g1030
- '(any .
- each-any))))
- g996)
- (if (memv g998
- '(local-syntax-form))
- (g445 g993
- g996
- g991
- g994
- g995
- (lambda (g1040
- g1037
- g1039
- g1038)
- (g986 ((letrec ((g1041
- (lambda (g1042)
- (if (null?
- g1042)
- (cdr g990)
- (cons (cons g1037
- (g393 (car g1042)
- g1039))
- (g1041
- (cdr g1042)))))))
- g1041)
- g1040)
- g987
- g989
- g988)))
- (g983 g989
- g987
- (append
- g988
- (cons (cons g991
- (g394 g996
- g994
- g995))
- (cdr g990)))))))))))
- g997))))
- (cdar g990)
- (caar g990))))))
- g986)
- g981
- '()
- '()
- '()))))
- (g426
- (lambda (g1560 g1559)
- (letrec ((g1564
- (lambda (g1597 g1595 g1596)
- ((lambda (g1598)
- (if g1598
- (if (g367 ((lambda (g1599)
- ((lambda (g1600)
- (if (g90 g1600)
- (annotation-expression
- g1600)
- g1600))
- (if (g204 g1599)
- (g205 g1599)
- g1599)))
- g1597)
- g1598
- (if (symbol? g1597)
- (g264 '((top)))
- (g264 (g206 g1597))))
- (cons g1597 g1596)
- g1596)
- (g1562
- (g404 g1595)
- (lambda (g1602 g1601)
- (if (g1561 g1602 g1597)
- (cons g1602 g1601)
- g1601))
- g1596)))
- (g405 g1595))))
- (g1563
- (lambda (g1575 g1573 g1574)
- (if (g403 g1575)
- (if (g403 g1573)
- (call-with-values
- (lambda ()
- ((lambda (g1581 g1580)
- (if (fx> (vector-length g1581)
- (vector-length g1580))
- (values g1575 g1580)
- (values g1573 g1581)))
- (g404 g1575)
- (g404 g1573)))
- (lambda (g1577 g1576)
- (g1562
- g1576
- (lambda (g1579 g1578)
- (g1564 g1579 g1577 g1578))
- g1574)))
- (g1564 g1573 g1575 g1574))
- (if (g403 g1573)
- (g1564 g1575 g1573 g1574)
- (if (g1561 g1575 g1573)
- (cons g1575 g1574)
- g1574)))))
- (g1562
- (lambda (g1590 g1588 g1589)
- ((lambda (g1591)
- ((letrec ((g1592
- (lambda (g1594 g1593)
- (if (= g1594 g1591)
- g1593
- (g1592
- (+ g1594 '1)
- (g1588
- (vector-ref g1590 g1594)
- g1593))))))
- g1592)
- '0
- g1589))
- (vector-length g1590))))
- (g1561
- (lambda (g1583 g1582)
- (if (symbol? g1583)
- (if (symbol? g1582)
- (eq? g1583 g1582)
- (if (eq? g1583
- ((lambda (g1584)
- ((lambda (g1585)
- (if (g90 g1585)
- (annotation-expression
- g1585)
- g1585))
- (if (g204 g1584)
- (g205 g1584)
- g1584)))
- g1582))
- (g373 (g264 (g206 g1582))
- (g264 '((top))))
- '#f))
- (if (symbol? g1582)
- (if (eq? g1582
- ((lambda (g1586)
- ((lambda (g1587)
- (if (g90 g1587)
- (annotation-expression
- g1587)
- g1587))
- (if (g204 g1586)
- (g205 g1586)
- g1586)))
- g1583))
- (g373 (g264 (g206 g1583))
- (g264 '((top))))
- '#f)
- (g388 g1583 g1582))))))
- (if (not (null? g1559))
- ((letrec ((g1565
- (lambda (g1568 g1566 g1567)
- (if (null? g1566)
- (if (not (null? g1567))
- ((lambda (g1569)
- (syntax-error
- g1560
- '"duplicate definition for "
- (symbol->string (car g1569))
- '" in"))
- (syntax-object->datum g1567))
- (void))
- ((letrec ((g1570
- (lambda (g1572 g1571)
- (if (null? g1572)
- (g1565
- (car g1566)
- (cdr g1566)
- g1571)
- (g1570
- (cdr g1572)
- (g1563
- g1568
- (car g1572)
- g1571))))))
- g1570)
- g1566
- g1567)))))
- g1565)
- (car g1559)
- (cdr g1559)
- '())
- (void)))))
- (g425
- (lambda (g1057 g1055 g1056)
- (letrec ((g1058
- (lambda (g1065 g1064)
- (ormap
- (lambda (g1066)
- (if (g403 g1066)
- ((lambda (g1067)
- (if g1067
- (g367 ((lambda (g1068)
- ((lambda (g1069)
- (if (g90 g1069)
- (annotation-expression
- g1069)
- g1069))
- (if (g204 g1068)
- (g205 g1068)
- g1068)))
- g1065)
- g1067
- (g264 (g206 g1065)))
- ((lambda (g1070)
- ((letrec ((g1071
- (lambda (g1072)
- (if (fx>= g1072
- '0)
- ((lambda (g1073)
- (if g1073
- g1073
- (g1071
- (- g1072
- '1))))
- (g388 g1065
- (vector-ref
- g1070
- g1072)))
- '#f))))
- g1071)
- (- (vector-length g1070)
- '1)))
- (g404 g1066))))
- (g405 g1066))
- (g388 g1065 g1066)))
- g1064))))
- ((letrec ((g1059
- (lambda (g1061 g1060)
- (if (null? g1061)
- (if (not (null? g1060))
- (syntax-error
- g1060
- '"missing definition for export(s)")
- (void))
- ((lambda (g1063 g1062)
- (if (g1058 g1063 g1056)
- (g1059 g1062 g1060)
- (g1059 g1062 (cons g1063 g1060))))
- (car g1061)
- (cdr g1061))))))
- g1059)
- g1055
- '()))))
- (g424
- (lambda (g1558 g1556 g1557)
- (set-cdr! g1558 (g246 g1556 g1557 (cdr g1558)))))
- (g423
- (lambda (g1075 g1074)
- (if (null? g1075)
- '()
- (if (g392 (car g1075) g1074)
- (g423 (cdr g1075) g1074)
- (cons (car g1075) (g423 (cdr g1075) g1074))))))
- (g422
- (lambda (g1491
- g1482
- g1490
- g1483
- g1489
- g1484
- g1488
- g1485
- g1487
- g1486)
- ((lambda (g1492)
- (g427 g1490
- (g394 g1491 g1483 g1489)
- (map (lambda (g1555) (cons g1482 g1555)) g1486)
- g1482
- g1487
- g1492
- g1484
- g1488
- (lambda (g1494 g1493)
- ((letrec ((g1495
- (lambda (g1500
- g1496
- g1499
- g1497
- g1498)
- (if (null? g1500)
- ((letrec ((g1501
- (lambda (g1504
- g1502
- g1503)
- (if (null? g1504)
- ((lambda (g1507
- g1505
- g1506)
- (begin (for-each
- (lambda (g1523)
- (apply
- (lambda (g1527
- g1524
- g1526
- g1525)
- (if g1524
- (g303 g1524
- g1526)
- (void)))
- g1523))
- g1498)
- (g190 '#f
- (list (g431 g1484
- g1488
- (lambda ()
- (if (null?
- g1498)
- (g446)
- (g190 '#f
- (map (lambda (g1518)
- (apply
- (lambda (g1522
- g1519
- g1521
- g1520)
- (list '$sc-put-cte
- (list 'quote
- g1521)
- (if (eq? g1522
- 'define-syntax-form)
- g1520
- (list 'quote
- (g231 'module
- (g409 g1520
- g1521))))))
- g1518))
- g1498)))))
- (g431 g1484
- g1488
- (lambda ()
- ((lambda (g1508)
- ((lambda (g1509)
- ((lambda (g1510)
- ((lambda ()
- (if g1508
- (list '$sc-put-cte
- (list 'quote
- (if (g373 (g264 (g206 g1485))
- (g264 '((top))))
- g1508
- ((lambda (g1511)
- (g203 g1508
- (g263 g1511
- (list (g304 (vector
- g1508)
- (vector
- g1511)
- (vector
- (g101 g1508)))))))
- (g264 (g206 g1485)))))
- g1510)
- ((lambda (g1512)
- (g190 '#f
- (list (list '$sc-put-cte
- (list 'quote
- g1512)
- g1510)
- (g430 g1512
- g1509))))
- (g101 'tmp))))))
- (list 'quote
- (g231 'module
- (g409 g1487
- g1509)))))
- (g101 g1508)))
- (if g1485
- ((lambda (g1513)
- ((lambda (g1514)
- (if (g90 g1514)
- (annotation-expression
- g1514)
- g1514))
- (if (g204 g1513)
- (g205 g1513)
- g1513)))
- g1485)
- '#f))))
- (g190 '#f
- (map (lambda (g1517)
- (list 'define
- g1517
- (g446)))
- g1499))
- (g191 '#f
- g1502
- g1505
- (g190 '#f
- (list (if (null?
- g1499)
- (g446)
- (g190 '#f
- (map (lambda (g1516
- g1515)
- (list 'set!
- g1516
- g1515))
- g1499
- g1507)))
- (if (null?
- g1506)
- (g446)
- (g190 '#f
- g1506)))))
- (g446)))))
- (map (lambda (g1530)
- (g432 (cdr g1530)
- (car g1530)
- '(())))
- g1497)
- (map (lambda (g1528)
- (g432 (cdr g1528)
- (car g1528)
- '(())))
- g1503)
- (map (lambda (g1529)
- (g432 (cdr g1529)
- (car g1529)
- '(())))
- g1493))
- ((lambda (g1531)
- ((lambda (g1532)
- (if (memv g1532
- '(define-form))
- ((lambda (g1533)
- (begin (g424 g1482
- (g302 (g414 g1531))
- (g231 'lexical
- g1533))
- (g1501
- (cdr g1504)
- (cons g1533
- g1502)
- (cons (g416 g1531)
- g1503))))
- (g451 (g413 g1531)))
- (if (memv g1532
- '(define-syntax-form
- module-form))
- (g1501
- (cdr g1504)
- g1502
- g1503)
- (error 'sc-expand-internal
- '"unexpected module binding type"))))
- (g412 g1531)))
- (car g1504))))))
- g1501)
- g1496
- '()
- '())
- ((lambda (g1535 g1534)
- (letrec ((g1536
- (lambda (g1551
- g1548
- g1550
- g1549)
- ((letrec ((g1552
- (lambda (g1554
- g1553)
- (if (null?
- g1554)
- (g1549)
- (if (g388 (g413 (car g1554))
- g1551)
- (g1550
- (car g1554)
- (g370 (reverse
- g1553)
- (cdr g1554)))
- (g1552
- (cdr g1554)
- (cons (car g1554)
- g1553)))))))
- g1552)
- g1548
- '()))))
- (g1536
- g1535
- g1496
- (lambda (g1538 g1537)
- ((lambda (g1541
- g1539
- g1540)
- ((lambda (g1543
- g1542)
- ((lambda (g1544)
- (if (memv g1544
- '(define-form))
- (begin (g303 g1539
- g1542)
- (g1495
- g1543
- g1537
- (cons g1542
- g1499)
- (cons (g416 g1538)
- g1497)
- g1498))
- (if (memv g1544
- '(define-syntax-form))
- (g1495
- g1543
- g1537
- g1499
- g1497
- (cons (list g1541
- g1539
- g1542
- (g416 g1538))
- g1498))
- (if (memv g1544
- '(module-form))
- ((lambda (g1545)
- (g1495
- (append
- (g401 g1545)
- g1543)
- g1537
- g1499
- g1497
- (cons (list g1541
- g1539
- g1542
- g1545)
- g1498)))
- (g416 g1538))
- (error 'sc-expand-internal
- '"unexpected module binding type")))))
- g1541))
- (append
- g1540
- g1534)
- (g101 ((lambda (g1546)
- ((lambda (g1547)
- (if (g90 g1547)
- (annotation-expression
- g1547)
- g1547))
- (if (g204 g1546)
- (g205 g1546)
- g1546)))
- g1535))))
- (g412 g1538)
- (g414 g1538)
- (g415 g1538)))
- (lambda ()
- (g1495
- g1534
- g1496
- g1499
- g1497
- g1498)))))
- (car g1500)
- (cdr g1500))))))
- g1495)
- g1492
- g1494
- '()
- '()
- '()))))
- (g401 g1487))))
- (g421 (lambda (g1077 g1076) (vector-set! g1077 '5 g1076)))
- (g420 (lambda (g1481 g1480) (vector-set! g1481 '4 g1480)))
- (g419 (lambda (g1079 g1078) (vector-set! g1079 '3 g1078)))
- (g418 (lambda (g1479 g1478) (vector-set! g1479 '2 g1478)))
- (g417 (lambda (g1081 g1080) (vector-set! g1081 '1 g1080)))
- (g416 (lambda (g1477) (vector-ref g1477 '5)))
- (g415 (lambda (g1082) (vector-ref g1082 '4)))
- (g414 (lambda (g1476) (vector-ref g1476 '3)))
- (g413 (lambda (g1083) (vector-ref g1083 '2)))
- (g412 (lambda (g1475) (vector-ref g1475 '1)))
- (g411
- (lambda (g1084)
- (if (vector? g1084)
- (if (= (vector-length g1084) '6)
- (eq? (vector-ref g1084 '0) 'module-binding)
- '#f)
- '#f)))
- (g410
- (lambda (g1474 g1470 g1473 g1471 g1472)
- (vector 'module-binding g1474 g1470 g1473 g1471 g1472)))
- (g409
- (lambda (g1086 g1085)
- (g402 (list->vector
- (map (lambda (g1087)
- (g369 (if (pair? g1087) (car g1087) g1087)))
- g1086))
- g1085)))
- (g408
- (lambda (g1468)
- (g402 (list->vector
- (map (lambda (g1469)
- (if (pair? g1469) (car g1469) g1469))
- g1468))
- '#f)))
- (g407 (lambda (g1089 g1088) (vector-set! g1089 '2 g1088)))
- (g406 (lambda (g1467 g1466) (vector-set! g1467 '1 g1466)))
- (g405 (lambda (g1090) (vector-ref g1090 '2)))
- (g404 (lambda (g1465) (vector-ref g1465 '1)))
- (g403
- (lambda (g1091)
- (if (vector? g1091)
- (if (= (vector-length g1091) '3)
- (eq? (vector-ref g1091 '0) 'interface)
- '#f)
- '#f)))
- (g402
- (lambda (g1464 g1463) (vector 'interface g1464 g1463)))
- (g401
- (lambda (g1092)
- ((letrec ((g1093
- (lambda (g1095 g1094)
- (if (null? g1095)
- g1094
- (g1093
- (cdr g1095)
- (if (pair? (car g1095))
- (g1093 (car g1095) g1094)
- (cons (car g1095) g1094)))))))
- g1093)
- g1092
- '())))
- (g400
- (lambda (g1390 g1385 g1389 g1386 g1388 g1387)
- (call-with-values
- (lambda () (g398 g1390 g1385 g1389 '#f g1387))
- (lambda (g1401 g1397 g1400 g1398 g1399)
- ((lambda (g1402)
- (if (memv g1402 '(begin-form))
- ((lambda (g1403)
- ((lambda (g1404)
- (if g1404
- (apply (lambda (g1405) (g446)) g1404)
- ((lambda (g1406)
- (if g1406
- (apply
- (lambda (g1409 g1407 g1408)
- (g396 (cons g1407 g1408)
- g1385
- g1398
- g1399
- g1386
- g1388
- g1387))
- g1406)
- (syntax-error g1403)))
- ($syntax-dispatch
- g1403
- '(any any . each-any)))))
- ($syntax-dispatch g1403 '(any))))
- g1400)
- (if (memv g1402 '(local-syntax-form))
- (g445 g1397
- g1400
- g1385
- g1398
- g1399
- (lambda (g1414 g1411 g1413 g1412)
- (g396 g1414
- g1411
- g1413
- g1412
- g1386
- g1388
- g1387)))
- (if (memv g1402 '(eval-when-form))
- ((lambda (g1415)
- ((lambda (g1416)
- (if g1416
- (apply
- (lambda (g1420
- g1417
- g1419
- g1418)
- ((lambda (g1422 g1421)
- (if (eq? g1386 'e)
- (if (memq 'eval
- g1422)
- (g396 g1421
- g1385
- g1398
- g1399
- 'e
- '(eval)
- g1387)
- (g446))
- (if (memq 'load
- g1422)
- (if ((lambda (g1423)
- (if g1423
- g1423
- (if (eq? g1386
- 'c&e)
- (memq 'eval
- g1422)
- '#f)))
- (memq 'compile
- g1422))
- (g396 g1421
- g1385
- g1398
- g1399
- 'c&e
- '(compile
- load)
- g1387)
- (if (memq g1386
- '(c c&e))
- (g396 g1421
- g1385
- g1398
- g1399
- 'c
- '(load)
- g1387)
- (g446)))
- (if ((lambda (g1424)
- (if g1424
- g1424
- (if (eq? g1386
- 'c&e)
- (memq 'eval
- g1422)
- '#f)))
- (memq 'compile
- g1422))
- (begin (g91 (g396 g1421
- g1385
- g1398
- g1399
- 'e
- '(eval)
- g1387))
- (g446))
- (g446)))))
- (g397 g1400 g1417 g1398)
- (cons g1419 g1418)))
- g1416)
- (syntax-error g1415)))
- ($syntax-dispatch
- g1415
- '(any each-any any . each-any))))
- g1400)
- (if (memv g1402 '(define-syntax-form))
- (g443 g1400
- g1398
- g1399
- (lambda (g1429 g1427 g1428)
- ((lambda (g1430)
- (begin ((lambda (g1435)
- ((lambda (g1436)
- ((lambda (g1437)
- (if (memv g1437
- '(displaced-lexical))
- (g250 g1430)
- (void)))
- (g232 g1436)))
- (g253 g1435
- g1385)))
- (g377 g1430
- '(())))
- (g431 g1386
- g1388
- (lambda ()
- (list '$sc-put-cte
- (list 'quote
- ((lambda (g1431)
- (if (g373 (g264 (g206 g1430))
- (g264 '((top))))
- g1431
- ((lambda (g1432)
- (g203 g1431
- (g263 g1432
- (list (g304 (vector
- g1431)
- (vector
- g1432)
- (vector
- (g101 g1431)))))))
- (g264 (g206 g1430)))))
- ((lambda (g1433)
- ((lambda (g1434)
- (if (g90 g1434)
- (annotation-expression
- g1434)
- g1434))
- (if (g204 g1433)
- (g205 g1433)
- g1433)))
- g1430)))
- (g432 g1427
- (g249 g1385)
- g1428))))))
- (g393 g1429 g1428))))
- (if (memv g1402 '(define-form))
- (g442 g1400
- g1398
- g1399
- (lambda (g1440 g1438 g1439)
- ((lambda (g1441)
- (begin ((lambda (g1448)
- ((lambda (g1449)
- ((lambda (g1450)
- (if (memv g1450
- '(displaced-lexical))
- (g250 g1441)
- (void)))
- (g232 g1449)))
- (g253 g1448
- g1385)))
- (g377 g1441
- '(())))
- ((lambda (g1442)
- ((lambda (g1443)
- (g190 '#f
- (list (g431 g1386
- g1388
- (lambda ()
- (list '$sc-put-cte
- (list 'quote
- (if (eq? g1442
- g1443)
- g1442
- ((lambda (g1445)
- (g203 g1442
- (g263 g1445
- (list (g304 (vector
- g1442)
- (vector
- g1445)
- (vector
- g1443))))))
- (g264 (g206 g1441)))))
- (list 'quote
- (g231 'global
- g1443)))))
- ((lambda (g1444)
- (begin (if (eq? g1386
- 'c&e)
- (g91 g1444)
- (void))
- g1444))
- (list 'define
- g1443
- (g432 g1438
- g1385
- g1439))))))
- (if (g373 (g264 (g206 g1441))
- (g264 '((top))))
- g1442
- (g101 g1442))))
- ((lambda (g1446)
- ((lambda (g1447)
- (if (g90 g1447)
- (annotation-expression
- g1447)
- g1447))
- (if (g204 g1446)
- (g205 g1446)
- g1446)))
- g1441))))
- (g393 g1440 g1439))))
- (if (memv g1402 '(module-form))
- ((lambda (g1452 g1451)
- (g440 g1400
- g1398
- g1399
- (g263 (g264 g1398)
- (cons g1451
- (g265 g1398)))
- (lambda (g1455
- g1453
- g1454)
- (if g1455
- (begin ((lambda (g1456)
- ((lambda (g1457)
- ((lambda (g1458)
- (if (memv g1458
- '(displaced-lexical))
- (g250 (g393 g1455
- g1398))
- (void)))
- (g232 g1457)))
- (g253 g1456
- g1452)))
- (g377 g1455
- '(())))
- (g422 g1400
- g1452
- g1451
- g1398
- g1399
- g1386
- g1388
- g1455
- g1453
- g1454))
- (g422 g1400
- g1452
- g1451
- g1398
- g1399
- g1386
- g1388
- '#f
- g1453
- g1454)))))
- (cons '("top-level module placeholder"
- placeholder)
- g1385)
- (g304 '() '() '()))
- (if (memv g1402
- '(import-form))
- (g441 g1400
- g1398
- g1399
- (lambda (g1459)
- (g431 g1386
- g1388
- (lambda ()
- (begin (if g1397
- (syntax-error
- (g394 g1400
- g1398
- g1399)
- '"not valid at top-level")
- (void))
- ((lambda (g1460)
- ((lambda (g1461)
- (if (memv g1461
- '(module))
- (g430 g1459
- (g405 (g233 g1460)))
- (if (memv g1461
- '(displaced-lexical))
- (g250 g1459)
- (syntax-error
- g1459
- '"import from unknown module"))))
- (g232 g1460)))
- (g253 (g377 g1459
- '(()))
- '())))))))
- ((lambda (g1462)
- (begin (if (eq? g1386
- 'c&e)
- (g91 g1462)
- (void))
- g1462))
- (g433 g1401
- g1397
- g1400
- g1385
- g1398
- g1399))))))))))
- g1401)))))
- (g399
- (lambda (g1099 g1096 g1098 g1097)
- (call-with-values
- (lambda () (g398 g1099 g1096 g1098 '#f g1097))
- (lambda (g1104 g1100 g1103 g1101 g1102)
- (g433 g1104 g1100 g1103 g1096 g1101 g1102)))))
- (g398
- (lambda (g1370 g1366 g1369 g1367 g1368)
- (if (symbol? g1370)
- ((lambda (g1371)
- ((lambda (g1372)
- ((lambda (g1373)
- ((lambda ()
- ((lambda (g1374)
- (if (memv g1374 '(lexical))
- (values
- g1373
- (g233 g1372)
- g1370
- g1369
- g1367)
- (if (memv g1374 '(global))
- (values
- g1373
- (g233 g1372)
- g1370
- g1369
- g1367)
- (if (memv g1374 '(macro macro!))
- (g398 (g436 (g233 g1372)
- g1370
- g1366
- g1369
- g1367
- g1368)
- g1366
- '(())
- '#f
- g1368)
- (values
- g1373
- (g233 g1372)
- g1370
- g1369
- g1367)))))
- g1373))))
- (g232 g1372)))
- (g253 g1371 g1366)))
- (g377 g1370 g1369))
- (if (pair? g1370)
- ((lambda (g1375)
- (if (g256 g1375)
- ((lambda (g1376)
- ((lambda (g1377)
- ((lambda (g1378)
- ((lambda ()
- ((lambda (g1379)
- (if (memv g1379 '(lexical))
- (values
- 'lexical-call
- (g233 g1377)
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(macro macro!))
- (g398 (g436 (g233 g1377)
- g1370
- g1366
- g1369
- g1367
- g1368)
- g1366
- '(())
- '#f
- g1368)
- (if (memv g1379
- '(core))
- (values
- g1378
- (g233 g1377)
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(local-syntax))
- (values
- 'local-syntax-form
- (g233 g1377)
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(begin))
- (values
- 'begin-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(eval-when))
- (values
- 'eval-when-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(define))
- (values
- 'define-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(define-syntax))
- (values
- 'define-syntax-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(module-key))
- (values
- 'module-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(import))
- (values
- 'import-form
- (if (g233 g1377)
- (g393 g1375
- g1369)
- '#f)
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(set!))
- (g435 g1370
- g1366
- g1369
- g1367
- g1368)
- (values
- 'call
- '#f
- g1370
- g1369
- g1367)))))))))))))
- g1378))))
- (g232 g1377)))
- (g253 g1376 g1366)))
- (g377 g1375 g1369))
- (values 'call '#f g1370 g1369 g1367)))
- (car g1370))
- (if (g204 g1370)
- (g398 (g205 g1370)
- g1366
- (g371 g1369 (g206 g1370))
- '#f
- g1368)
- (if (g90 g1370)
- (g398 (annotation-expression g1370)
- g1366
- g1369
- (annotation-source g1370)
- g1368)
- (if ((lambda (g1380)
- ((lambda (g1381)
- (if g1381
- g1381
- ((lambda (g1382)
- (if g1382
- g1382
- ((lambda (g1383)
- (if g1383
- g1383
- ((lambda (g1384)
- (if g1384
- g1384
- (null?
- g1380)))
- (char?
- g1380))))
- (string? g1380))))
- (number? g1380))))
- (boolean? g1380)))
- g1370)
- (values 'constant '#f g1370 g1369 g1367)
- (values
- 'other
- '#f
- g1370
- g1369
- g1367))))))))
- (g397
- (lambda (g1107 g1105 g1106)
- ((letrec ((g1108
- (lambda (g1110 g1109)
- (if (null? g1110)
- g1109
- (g1108
- (cdr g1110)
- (cons ((lambda (g1111)
- (if (g378 g1111
- '#(syntax-object
- compile
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(when-list
- situations)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e when-list w)
- #((top)
- (top)
- (top))
- #("i" "i" "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- 'compile
- (if (g378 g1111
- '#(syntax-object
- load
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(when-list
- situations)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- when-list
- w)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- 'load
- (if (g378 g1111
- '#(syntax-object
- eval
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(when-list
- situations)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- when-list
- w)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- 'eval
- (syntax-error
- (g393 g1111 g1106)
- '"invalid eval-when situation")))))
- (car g1110))
- g1109))))))
- g1108)
- g1105
- '())))
- (g396
- (lambda (g1358 g1352 g1357 g1353 g1356 g1354 g1355)
- (g190 g1353
- ((letrec ((g1359
- (lambda (g1364 g1360 g1363 g1361 g1362)
- (if (null? g1364)
- '()
- ((lambda (g1365)
- (cons g1365
- (g1359
- (cdr g1364)
- g1360
- g1363
- g1361
- g1362)))
- (g400 (car g1364)
- g1360
- g1363
- g1361
- g1362
- g1355))))))
- g1359)
- g1358
- g1352
- g1357
- g1356
- g1354))))
- (g395
- (lambda (g1115 g1112 g1114 g1113)
- (g190 g1113
- ((letrec ((g1116
- (lambda (g1119 g1117 g1118)
- (if (null? g1119)
- '()
- ((lambda (g1120)
- (cons g1120
- (g1116
- (cdr g1119)
- g1117
- g1118)))
- (g432 (car g1119) g1117 g1118))))))
- g1116)
- g1115
- g1112
- g1114))))
- (g394
- (lambda (g1351 g1349 g1350)
- (g393 (if g1350 (make-annotation g1351 g1350 '#f) g1351)
- g1349)))
- (g393
- (lambda (g1122 g1121)
- (if (if (null? (g264 g1121)) (null? (g265 g1121)) '#f)
- g1122
- (if (g204 g1122)
- (g203 (g205 g1122) (g371 g1121 (g206 g1122)))
- (if (null? g1122) g1122 (g203 g1122 g1121))))))
- (g392
- (lambda (g1347 g1346)
- (if (not (null? g1346))
- ((lambda (g1348)
- (if g1348 g1348 (g392 g1347 (cdr g1346))))
- (g388 g1347 (car g1346)))
- '#f)))
- (g391
- (lambda (g1125 g1123 g1124)
- ((letrec ((g1126
- (lambda (g1128 g1127)
- (if (null? g1128)
- (syntax-error g1123)
- (if (g256 (car g1128))
- (if (g392 (car g1128) g1127)
- (syntax-error
- (car g1128)
- '"duplicate "
- g1124)
- (g1126
- (cdr g1128)
- (cons (car g1128) g1127)))
- (syntax-error
- (car g1128)
- '"invalid "
- g1124))))))
- g1126)
- g1125
- '())))
- (g390
- (lambda (g1342)
- ((letrec ((g1343
- (lambda (g1344)
- ((lambda (g1345)
- (if g1345
- g1345
- (if (not (g392 (car g1344) (cdr g1344)))
- (g1343 (cdr g1344))
- '#f)))
- (null? g1344)))))
- g1343)
- g1342)))
- (g389
- (lambda (g1129)
- (if ((letrec ((g1130
- (lambda (g1131)
- ((lambda (g1132)
- (if g1132
- g1132
- (if (g256 (car g1131))
- (g1130 (cdr g1131))
- '#f)))
- (null? g1131)))))
- g1130)
- g1129)
- (g390 g1129)
- '#f)))
- (g388
- (lambda (g1337 g1336)
- (if (if (g204 g1337) (g204 g1336) '#f)
- (if (eq? ((lambda (g1339)
- (if (g90 g1339)
- (annotation-expression g1339)
- g1339))
- (g205 g1337))
- ((lambda (g1338)
- (if (g90 g1338)
- (annotation-expression g1338)
- g1338))
- (g205 g1336)))
- (g373 (g264 (g206 g1337)) (g264 (g206 g1336)))
- '#f)
- (eq? ((lambda (g1341)
- (if (g90 g1341)
- (annotation-expression g1341)
- g1341))
- g1337)
- ((lambda (g1340)
- (if (g90 g1340)
- (annotation-expression g1340)
- g1340))
- g1336)))))
- (g378
- (lambda (g1134 g1133)
- (if (eq? ((lambda (g1137)
- ((lambda (g1138)
- (if (g90 g1138)
- (annotation-expression g1138)
- g1138))
- (if (g204 g1137) (g205 g1137) g1137)))
- g1134)
- ((lambda (g1135)
- ((lambda (g1136)
- (if (g90 g1136)
- (annotation-expression g1136)
- g1136))
- (if (g204 g1135) (g205 g1135) g1135)))
- g1133))
- (eq? (g377 g1134 '(())) (g377 g1133 '(())))
- '#f)))
- (g377
- (lambda (g1333 g1332)
- (call-with-values
- (lambda () (g374 g1333 g1332))
- (lambda (g1335 g1334)
- (if (g301 g1335) (g302 g1335) g1335)))))
- (g376
- (lambda (g1140 g1139)
- (call-with-values
- (lambda () (g374 g1140 g1139))
- (lambda (g1142 g1141) g1142))))
- (g375
- (lambda (g1329 g1328)
- (call-with-values
- (lambda () (g374 g1329 g1328))
- (lambda (g1331 g1330)
- (values (if (g301 g1331) (g302 g1331) g1331) g1330)))))
- (g374
- (lambda (g1144 g1143)
- (letrec ((g1147
- (lambda (g1174 g1170 g1173 g1171 g1172)
- ((lambda (g1175)
- ((letrec ((g1176
- (lambda (g1177)
- (if (= g1177 g1175)
- (g1145
- g1174
- (cdr g1170)
- g1173)
- (if (if (eq? (vector-ref
- g1171
- g1177)
- g1174)
- (g373 g1173
- (vector-ref
- (g307 g1172)
- g1177))
- '#f)
- (values
- (vector-ref
- (g308 g1172)
- g1177)
- g1173)
- (g1176 (+ g1177 '1)))))))
- g1176)
- '0))
- (vector-length g1171))))
- (g1146
- (lambda (g1159 g1155 g1158 g1156 g1157)
- ((letrec ((g1160
- (lambda (g1162 g1161)
- (if (null? g1162)
- (g1145 g1159 (cdr g1155) g1158)
- (if (if (eq? (car g1162) g1159)
- (g373 g1158
- (list-ref
- (g307 g1157)
- g1161))
- '#f)
- (values
- (list-ref
- (g308 g1157)
- g1161)
- g1158)
- (if (g357 (car g1162))
- ((lambda (g1163)
- (if g1163
- ((lambda (g1164)
- (if (symbol?
- g1164)
- (values
- g1164
- g1158)
- (g375 g1164
- '(()))))
- g1163)
- (g1160
- (cdr g1162)
- g1161)))
- (g367 g1159
- (g358 (car g1162))
- g1158))
- (if (if (eq? (car g1162)
- g354)
- (g373 g1158
- (list-ref
- (g307 g1157)
- g1161))
- '#f)
- (values '#f g1158)
- (g1160
- (cdr g1162)
- (+ g1161
- '1)))))))))
- g1160)
- g1156
- '0)))
- (g1145
- (lambda (g1167 g1165 g1166)
- (if (null? g1165)
- (values g1167 g1166)
- ((lambda (g1168)
- (if (eq? g1168 'shift)
- (g1145 g1167 (cdr g1165) (cdr g1166))
- ((lambda (g1169)
- (if (vector? g1169)
- (g1147
- g1167
- g1165
- g1166
- g1169
- g1168)
- (g1146
- g1167
- g1165
- g1166
- g1169
- g1168)))
- (g306 g1168))))
- (car g1165))))))
- (if (symbol? g1144)
- (g1145 g1144 (g265 g1143) (g264 g1143))
- (if (g204 g1144)
- ((lambda (g1149 g1148)
- ((lambda (g1150)
- (call-with-values
- (lambda ()
- (g1145 g1149 (g265 g1143) g1150))
- (lambda (g1152 g1151)
- (if (eq? g1152 g1149)
- (g1145 g1149 (g265 g1148) g1151)
- (values g1152 g1151)))))
- (g372 (g264 g1143) (g264 g1148))))
- ((lambda (g1153)
- (if (g90 g1153)
- (annotation-expression g1153)
- g1153))
- (g205 g1144))
- (g206 g1144))
- (if (g90 g1144)
- (g1145
- ((lambda (g1154)
- (if (g90 g1154)
- (annotation-expression g1154)
- g1154))
- g1144)
- (g265 g1143)
- (g264 g1143))
- (g93 'id-var-name '"invalid id" g1144)))))))
- (g373
- (lambda (g1326 g1325)
- ((lambda (g1327)
- (if g1327
- g1327
- (if (not (null? g1326))
- (if (not (null? g1325))
- (if (eq? (car g1326) (car g1325))
- (g373 (cdr g1326) (cdr g1325))
- '#f)
- '#f)
- '#f)))
- (eq? g1326 g1325))))
- (g372 (lambda (g1179 g1178) (g370 g1179 g1178)))
- (g371
- (lambda (g1322 g1321)
- ((lambda (g1324 g1323)
- (if (null? g1324)
- (if (null? g1323)
- g1321
- (g263 (g264 g1321) (g370 g1323 (g265 g1321))))
- (g263 (g370 g1324 (g264 g1321))
- (g370 g1323 (g265 g1321)))))
- (g264 g1322)
- (g265 g1322))))
- (g370
- (lambda (g1181 g1180)
- (if (null? g1180) g1181 (append g1181 g1180))))
- (g369
- (lambda (g1315)
- (call-with-values
- (lambda () (g375 g1315 '(())))
- (lambda (g1317 g1316)
- (begin (if (not g1317)
- (syntax-error
- g1315
- '"identifier not visible for export")
- (void))
- ((lambda (g1318)
- (g203 g1318
- (g263 g1316
- (list (g304 (vector g1318)
- (vector g1316)
- (vector g1317))))))
- ((lambda (g1319)
- ((lambda (g1320)
- (if (g90 g1320)
- (annotation-expression g1320)
- g1320))
- (if (g204 g1319) (g205 g1319) g1319)))
- g1315)))))))
- (g368
- (lambda (g1184 g1182 g1183)
- (if (null? g1184)
- g1183
- (g263 (g264 g1183)
- (cons ((lambda (g1185)
- ((lambda (g1186)
- ((lambda (g1188 g1187)
- (begin ((letrec ((g1189
- (lambda (g1191
- g1190)
- (if (not (null?
- g1191))
- (call-with-values
- (lambda ()
- (g262 (car g1191)
- g1183))
- (lambda (g1193
- g1192)
- (begin (vector-set!
- g1188
- g1190
- g1193)
- (vector-set!
- g1187
- g1190
- g1192)
- (g1189
- (cdr g1191)
- (+ g1190
- '1)))))
- (void)))))
- g1189)
- g1184
- '0)
- (g304 g1188 g1187 g1185)))
- (make-vector g1186)
- (make-vector g1186)))
- (vector-length g1185)))
- (list->vector g1182))
- (g265 g1183))))))
- (g367
- (lambda (g1310 g1308 g1309)
- ((lambda (g1311)
- (if g1311
- ((letrec ((g1312
- (lambda (g1313)
- (if (pair? g1313)
- ((lambda (g1314)
- (if g1314
- g1314
- (g1312 (cdr g1313))))
- (g1312 (car g1313)))
- (if (g373 g1309 (g264 (g206 g1313)))
- g1313
- '#f)))))
- g1312)
- g1311)
- '#f))
- (g100 g1310 g1308))))
- (g366
- (lambda (g1195 g1194)
- (g309 g1195 (cons (g356 g1194) (g306 g1195)))))
- (g365
- (lambda (g1307 g1306)
- (begin (g309 g1307 (cons g354 (g306 g1307)))
- (g310 g1307 (cons (g264 g1306) (g307 g1307))))))
- (g364 (lambda (g1197 g1196) (g365 g1197 (g206 g1196))))
- (g363
- (lambda (g1304 g1302 g1303)
- (begin (g309 g1304
- (cons ((lambda (g1305)
- (if (g90 g1305)
- (annotation-expression g1305)
- g1305))
- (g205 g1302))
- (g306 g1304)))
- (g310 g1304 (cons (g264 (g206 g1302)) (g307 g1304)))
- (g311 g1304 (cons g1303 (g308 g1304))))))
- (g358 cdr)
- (g357
- (lambda (g1301)
- (if (pair? g1301) (eq? (car g1301) g355) '#f)))
- (g356 (lambda (g1198) (cons g355 g1198)))
- (g355 'import-token)
- (g354 '#f)
- (g349
- (lambda (g1300)
- (g263 (cons '#f (g264 g1300)) (cons 'shift (g265 g1300)))))
- (g311 (lambda (g1200 g1199) (vector-set! g1200 '3 g1199)))
- (g310 (lambda (g1299 g1298) (vector-set! g1299 '2 g1298)))
- (g309 (lambda (g1202 g1201) (vector-set! g1202 '1 g1201)))
- (g308 (lambda (g1297) (vector-ref g1297 '3)))
- (g307 (lambda (g1203) (vector-ref g1203 '2)))
- (g306 (lambda (g1296) (vector-ref g1296 '1)))
- (g305
- (lambda (g1204)
- (if (vector? g1204)
- (if (= (vector-length g1204) '4)
- (eq? (vector-ref g1204 '0) 'ribcage)
- '#f)
- '#f)))
- (g304
- (lambda (g1295 g1293 g1294)
- (vector 'ribcage g1295 g1293 g1294)))
- (g303 set-car!)
- (g302 car)
- (g301 pair?)
- (g300 (lambda () (list (g297))))
- (g299
- (lambda (g1205)
- (if (null? g1205) '() (cons (g297) (g299 (cdr g1205))))))
- (g298
- (lambda (g1290)
- ((lambda (g1291)
- (if g1291
- g1291
- ((lambda (g1292) (if g1292 g1292 (g301 g1290)))
- (symbol? g1290))))
- (string? g1290))))
- (g297 (lambda () (string '#\i)))
- (g265 cdr)
- (g264 car)
- (g263 cons)
- (g262
- (lambda (g1207 g1206)
- (if (g204 g1207)
- (values
- ((lambda (g1208)
- (if (g90 g1208)
- (annotation-expression g1208)
- g1208))
- (g205 g1207))
- (g372 (g264 g1206) (g264 (g206 g1207))))
- (values
- ((lambda (g1209)
- (if (g90 g1209)
- (annotation-expression g1209)
- g1209))
- g1207)
- (g264 g1206)))))
- (g256
- (lambda (g1288)
- (if (symbol? g1288)
- '#t
- (if (g204 g1288)
- (symbol?
- ((lambda (g1289)
- (if (g90 g1289)
- (annotation-expression g1289)
- g1289))
- (g205 g1288)))
- (if (g90 g1288)
- (symbol? (annotation-expression g1288))
- '#f)))))
- (g255
- (lambda (g1210)
- (if (g204 g1210)
- (symbol?
- ((lambda (g1211)
- (if (g90 g1211)
- (annotation-expression g1211)
- g1211))
- (g205 g1210)))
- '#f)))
- (g254
- (lambda (g1287 g1285 g1286) (g98 g1285 (g231 g1287 g1286))))
- (g253
- (lambda (g1213 g1212)
- (letrec ((g1214
- (lambda (g1221 g1220)
- (begin (g234 g1221 (g232 g1220))
- (g235 g1221 (g233 g1220))))))
- ((lambda (g1215)
- ((lambda (g1216)
- (if (memv g1216 '(deferred))
- (begin (g1214
- g1215
- ((lambda (g1217)
- ((lambda (g1218)
- (if g1218
- g1218
- (syntax-error
- g1217
- '"invalid transformer")))
- (g252 g1217)))
- (g92 (g233 g1215))))
- ((lambda (g1219) g1215) (g232 g1215)))
- g1215))
- (g232 g1215)))
- (g251 g1213 g1212)))))
- (g252
- (lambda (g1283)
- (if (procedure? g1283)
- (g231 'macro g1283)
- (if (g236 g1283)
- ((lambda (g1284)
- (if (memv g1284 '(core macro macro!))
- (if (procedure? (g233 g1283)) g1283 '#f)
- (if (memv g1284 '(module))
- (if (g403 (g233 g1283)) g1283 '#f)
- g1283)))
- (g232 g1283))
- '#f))))
- (g251
- (lambda (g1223 g1222)
- ((lambda (g1224)
- (if g1224
- (cdr g1224)
- (if (symbol? g1223)
- ((lambda (g1225)
- (if g1225 g1225 (g231 'global g1223)))
- (g99 g1223))
- (g231 'displaced-lexical '#f))))
- (assq g1223 g1222))))
- (g250
- (lambda (g1282)
- (syntax-error
- g1282
- (if (g377 g1282 '(()))
- '"identifier out of context"
- '"identifier not visible"))))
- (g249
- (lambda (g1226)
- (if (null? g1226)
- '()
- ((lambda (g1227)
- (if (eq? (cadr g1227) 'lexical)
- (g249 (cdr g1226))
- (cons g1227 (g249 (cdr g1226)))))
- (car g1226)))))
- (g248
- (lambda (g1281 g1279 g1280)
- (if (null? g1281)
- g1280
- (g248 (cdr g1281)
- (cdr g1279)
- (g246 (car g1281)
- (g231 'lexical (car g1279))
- g1280)))))
- (g247
- (lambda (g1230 g1228 g1229)
- (if (null? g1230)
- g1229
- (g247 (cdr g1230)
- (cdr g1228)
- (g246 (car g1230) (car g1228) g1229)))))
- (g246
- (lambda (g1278 g1276 g1277)
- (cons (cons g1278 g1276) g1277)))
- (g236
- (lambda (g1231)
- (if (pair? g1231) (symbol? (car g1231)) '#f)))
- (g235 set-cdr!)
- (g234 set-car!)
- (g233 cdr)
- (g232 car)
- (g231 (lambda (g1275 g1274) (cons g1275 g1274)))
- (g223
- (lambda (g1232)
- (if (g90 g1232)
- (annotation-source g1232)
- (if (g204 g1232) (g223 (g205 g1232)) '#f))))
- (g208 (lambda (g1273 g1272) (vector-set! g1273 '2 g1272)))
- (g207 (lambda (g1234 g1233) (vector-set! g1234 '1 g1233)))
- (g206 (lambda (g1271) (vector-ref g1271 '2)))
- (g205 (lambda (g1235) (vector-ref g1235 '1)))
- (g204
- (lambda (g1270)
- (if (vector? g1270)
- (if (= (vector-length g1270) '3)
- (eq? (vector-ref g1270 '0) 'syntax-object)
- '#f)
- '#f)))
- (g203
- (lambda (g1237 g1236) (vector 'syntax-object g1237 g1236)))
- (g191
- (lambda (g1269 g1266 g1268 g1267)
- (if (null? g1266)
- g1267
- (list 'letrec (map list g1266 g1268) g1267))))
- (g190
- (lambda (g1239 g1238)
- (if (null? (cdr g1238)) (car g1238) (cons 'begin g1238))))
- (g101
- ((lambda (g1251)
- (letrec ((g1254
- (lambda (g1260)
- ((letrec ((g1261
- (lambda (g1263 g1262)
- (if (< g1263 g1251)
- (list->string
- (cons (g1253 g1263) g1262))
- ((lambda (g1265 g1264)
- (g1261
- g1264
- (cons (g1253 g1265)
- g1262)))
- (modulo g1263 g1251)
- (quotient g1263 g1251))))))
- g1261)
- g1260
- '())))
- (g1253
- (lambda (g1259) (integer->char (+ g1259 '33))))
- (g1252 (lambda () '0)))
- ((lambda (g1256 g1255)
- (lambda (g1257)
- (begin (set! g1255 (+ g1255 '1))
- ((lambda (g1258) g1258)
- (string->symbol
- (string-append
- '"#"
- g1256
- (g1254 g1255)))))))
- (g1254 (g1252))
- '-1)))
- (- '127 '32 '2)))
- (g100 (lambda (g1241 g1240) (getprop g1241 g1240)))
- (g99 (lambda (g1250) (getprop g1250 '*sc-expander*)))
- (g98 (lambda (g1243 g1242) ($sc-put-cte g1243 g1242)))
- (g93
- (lambda (g1249 g1247 g1248)
- (error g1249 '"~a ~s" g1247 g1248)))
- (g92 (lambda (g1244) (eval (list g53 g1244))))
- (g91 (lambda (g1246) (eval (list g53 g1246))))
- (g90 (lambda (g1245) '#f))
- (g53 '"noexpand"))
- (begin (set! $sc-put-cte
- (lambda (g802 g801)
- (letrec ((g805
- (lambda (g831 g830)
- ((lambda (g832)
- (putprop g832 '*sc-expander* g830))
- (if (symbol? g831) g831 (g377 g831 '(()))))))
- (g804
- (lambda (g815 g814)
- (g429 (lambda (g816) (g803 g816 g814)) g815)))
- (g803
- (lambda (g818 g817)
- (letrec ((g820
- (lambda (g828 g827)
- (if (pair? g827)
- (if (g388 (car g827) g828)
- (g820 g828 (cdr g827))
- (g819 (car g827)
- (g820 g828
- (cdr g827))))
- (if ((lambda (g829)
- (if g829
- g829
- (g388 g827 g828)))
- (not g827))
- '#f
- g827))))
- (g819
- (lambda (g826 g825)
- (if (not g825)
- g826
- (cons g826 g825)))))
- ((lambda (g821)
- ((lambda (g822)
- (if (if (not g822) (symbol? g818) '#f)
- (remprop g821 g817)
- (putprop
- g821
- g817
- (g819 g818 g822))))
- (g820 g818 (getprop g821 g817))))
- ((lambda (g823)
- ((lambda (g824)
- (if (g90 g824)
- (annotation-expression g824)
- g824))
- (if (g204 g823) (g205 g823) g823)))
- g818))))))
- ((lambda (g806)
- ((lambda (g807)
- (if (memv g807 '(module))
- (begin ((lambda (g808)
- (g804 (g404 g808) (g405 g808)))
- (g233 g806))
- (g805 g802 g806))
- (if (memv g807 '(do-import))
- ((lambda (g809)
- ((lambda (g810)
- ((lambda (g811)
- (if (memv g811 '(module))
- ((lambda (g812)
- (begin (if (not (eq? (g405 g812)
- g809))
- (syntax-error
- g802
- '"import mismatch for module")
- (void))
- (g804 (g404 g812)
- '*top*)))
- (g233 g810))
- (syntax-error
- g802
- '"import from unknown module")))
- (g232 g810)))
- (g253 (g377 g802 '(())) '())))
- (g233 g801))
- (g805 g802 g806))))
- (g232 g806)))
- ((lambda (g813)
- (if g813
- g813
- (error 'define-syntax
- '"invalid transformer ~s"
- g801)))
- (g252 g801))))))
- (g254 'local-syntax 'letrec-syntax '#t)
- (g254 'local-syntax 'let-syntax '#f)
- (g254 'core
- 'fluid-let-syntax
- (lambda (g456 g453 g455 g454)
- ((lambda (g457)
- ((lambda (g458)
- (if (if g458
- (apply
- (lambda (g463 g459 g462 g460 g461)
- (g389 g459))
- g458)
- '#f)
- (apply
- (lambda (g469 g465 g468 g466 g467)
- ((lambda (g470)
- (begin (for-each
- (lambda (g477 g476)
- ((lambda (g478)
- (if (memv g478
- '(displaced-lexical))
- (g250 (g393 g477
- g455))
- (void)))
- (g232 (g253 g476 g453))))
- g465
- g470)
- (g437 (cons g466 g467)
- (g394 g456 g455 g454)
- (g247 g470
- ((lambda (g471)
- (map (lambda (g473)
- (g231 'deferred
- (g432 g473
- g471
- g455)))
- g468))
- (g249 g453))
- g453)
- g455)))
- (map (lambda (g480) (g377 g480 g455))
- g465)))
- g458)
- ((lambda (g481)
- (syntax-error (g394 g456 g455 g454)))
- g457)))
- ($syntax-dispatch
- g457
- '(any #(each (any any)) any . each-any))))
- g456)))
- (g254 'core
- 'quote
- (lambda (g795 g792 g794 g793)
- ((lambda (g796)
- ((lambda (g797)
- (if g797
- (apply
- (lambda (g799 g798)
- (list 'quote (g450 g798 g794)))
- g797)
- ((lambda (g800)
- (syntax-error (g394 g795 g794 g793)))
- g796)))
- ($syntax-dispatch g796 '(any any))))
- g795)))
- (g254 'core
- 'syntax
- ((lambda ()
- (letrec ((g489
- (lambda (g584)
- ((lambda (g585)
- (if (memv g585 '(ref))
- (cadr g584)
- (if (memv g585 '(primitive))
- (cadr g584)
- (if (memv g585 '(quote))
- (list 'quote (cadr g584))
- (if (memv g585 '(lambda))
- (list 'lambda
- (cadr g584)
- (g489 (caddr
- g584)))
- (if (memv g585 '(map))
- ((lambda (g586)
- (cons (if (= (length
- g586)
- '2)
- 'map
- 'map)
- g586))
- (map g489
- (cdr g584)))
- (cons (car g584)
- (map g489
- (cdr g584)))))))))
- (car g584))))
- (g488
- (lambda (g502)
- (if (eq? (car g502) 'list)
- (cons 'vector (cdr g502))
- (if (eq? (car g502) 'quote)
- (list 'quote
- (list->vector (cadr g502)))
- (list 'list->vector g502)))))
- (g487
- (lambda (g583 g582)
- (if (equal? g582 ''())
- g583
- (list 'append g583 g582))))
- (g486
- (lambda (g504 g503)
- ((lambda (g505)
- (if (memv g505 '(quote))
- (if (eq? (car g504) 'quote)
- (list 'quote
- (cons (cadr g504)
- (cadr g503)))
- (if (eq? (cadr g503) '())
- (list 'list g504)
- (list 'cons g504 g503)))
- (if (memv g505 '(list))
- (cons 'list
- (cons g504 (cdr g503)))
- (list 'cons g504 g503))))
- (car g503))))
- (g485
- (lambda (g575 g574)
- ((lambda (g577 g576)
- (if (eq? (car g575) 'ref)
- (car g576)
- (if (andmap
- (lambda (g578)
- (if (eq? (car g578) 'ref)
- (memq (cadr g578) g577)
- '#f))
- (cdr g575))
- (cons 'map
- (cons (list 'primitive
- (car g575))
- (map ((lambda (g579)
- (lambda (g580)
- (cdr (assq (cadr g580)
- g579))))
- (map cons
- g577
- g576))
- (cdr g575))))
- (cons 'map
- (cons (list 'lambda
- g577
- g575)
- g576)))))
- (map cdr g574)
- (map (lambda (g581)
- (list 'ref (car g581)))
- g574))))
- (g484
- (lambda (g507 g506)
- (list 'apply
- '(primitive append)
- (g485 g507 g506))))
- (g483
- (lambda (g569 g566 g568 g567)
- (if (= g568 '0)
- (values g566 g567)
- (if (null? g567)
- (syntax-error
- g569
- '"missing ellipsis in syntax form")
- (call-with-values
- (lambda ()
- (g483 g569
- g566
- (- g568 '1)
- (cdr g567)))
- (lambda (g571 g570)
- ((lambda (g572)
- (if g572
- (values
- (cdr g572)
- g567)
- ((lambda (g573)
- (values
- g573
- (cons (cons (cons g571
- g573)
- (car g567))
- g570)))
- (g451 'tmp))))
- (assq g571 (car g567)))))))))
- (g482
- (lambda (g512 g508 g511 g509 g510)
- (if (g256 g508)
- ((lambda (g513)
- ((lambda (g514)
- (if (eq? (g232 g514) 'syntax)
- (call-with-values
- (lambda ()
- ((lambda (g517)
- (g483 g512
- (car g517)
- (cdr g517)
- g509))
- (g233 g514)))
- (lambda (g516 g515)
- (values
- (list 'ref g516)
- g515)))
- (if (g510 g508)
- (syntax-error
- g512
- '"misplaced ellipsis in syntax form")
- (values
- (list 'quote g508)
- g509))))
- (g253 g513 g511)))
- (g377 g508 '(())))
- ((lambda (g518)
- ((lambda (g519)
- (if (if g519
- (apply
- (lambda (g521 g520)
- (g510 g521))
- g519)
- '#f)
- (apply
- (lambda (g523 g522)
- (g482 g512
- g522
- g511
- g509
- (lambda (g524)
- '#f)))
- g519)
- ((lambda (g525)
- (if (if g525
- (apply
- (lambda (g528
- g526
- g527)
- (g510 g526))
- g525)
- '#f)
- (apply
- (lambda (g531
- g529
- g530)
- ((letrec ((g532
- (lambda (g534
- g533)
- ((lambda (g535)
- ((lambda (g536)
- (if (if g536
- (apply
- (lambda (g538
- g537)
- (g510 g538))
- g536)
- '#f)
- (apply
- (lambda (g540
- g539)
- (g532 g539
- (lambda (g541)
- (call-with-values
- (lambda ()
- (g533 (cons '()
- g541)))
- (lambda (g543
- g542)
- (if (null?
- (car g542))
- (syntax-error
- g512
- '"extra ellipsis in syntax form")
- (values
- (g484 g543
- (car g542))
- (cdr g542))))))))
- g536)
- ((lambda (g544)
- (call-with-values
- (lambda ()
- (g482 g512
- g534
- g511
- g509
- g510))
- (lambda (g546
- g545)
- (call-with-values
- (lambda ()
- (g533 g545))
- (lambda (g548
- g547)
- (values
- (g487 g548
- g546)
- g547))))))
- g535)))
- ($syntax-dispatch
- g535
- '(any .
- any))))
- g534))))
- g532)
- g530
- (lambda (g549)
- (call-with-values
- (lambda ()
- (g482 g512
- g531
- g511
- (cons '()
- g549)
- g510))
- (lambda (g551
- g550)
- (if (null?
- (car g550))
- (syntax-error
- g512
- '"extra ellipsis in syntax form")
- (values
- (g485 g551
- (car g550))
- (cdr g550))))))))
- g525)
- ((lambda (g552)
- (if g552
- (apply
- (lambda (g554
- g553)
- (call-with-values
- (lambda ()
- (g482 g512
- g554
- g511
- g509
- g510))
- (lambda (g556
- g555)
- (call-with-values
- (lambda ()
- (g482 g512
- g553
- g511
- g555
- g510))
- (lambda (g558
- g557)
- (values
- (g486 g556
- g558)
- g557))))))
- g552)
- ((lambda (g559)
- (if g559
- (apply
- (lambda (g561
- g560)
- (call-with-values
- (lambda ()
- (g482 g512
- (cons g561
- g560)
- g511
- g509
- g510))
- (lambda (g563
- g562)
- (values
- (g488 g563)
- g562))))
- g559)
- ((lambda (g565)
- (values
- (list 'quote
- g508)
- g509))
- g518)))
- ($syntax-dispatch
- g518
- '#(vector
- (any .
- each-any))))))
- ($syntax-dispatch
- g518
- '(any . any)))))
- ($syntax-dispatch
- g518
- '(any any . any)))))
- ($syntax-dispatch
- g518
- '(any any))))
- g508)))))
- (lambda (g493 g490 g492 g491)
- ((lambda (g494)
- ((lambda (g495)
- ((lambda (g496)
- (if g496
- (apply
- (lambda (g498 g497)
- (call-with-values
- (lambda ()
- (g482 g494
- g497
- g490
- '()
- g447))
- (lambda (g500 g499)
- (g489 g500))))
- g496)
- ((lambda (g501) (syntax-error g494))
- g495)))
- ($syntax-dispatch g495 '(any any))))
- g494))
- (g394 g493 g492 g491)))))))
- (g254 'core
- 'lambda
- (lambda (g785 g782 g784 g783)
- ((lambda (g786)
- ((lambda (g787)
- (if g787
- (apply
- (lambda (g789 g788)
- (g444 (g394 g785 g784 g783)
- g788
- g782
- g784
- (lambda (g791 g790)
- (list 'lambda g791 g790))))
- g787)
- (syntax-error g786)))
- ($syntax-dispatch g786 '(any . any))))
- g785)))
- (g254 'core
- 'letrec
- (lambda (g590 g587 g589 g588)
- ((lambda (g591)
- ((lambda (g592)
- (if g592
- (apply
- (lambda (g597 g593 g596 g594 g595)
- ((lambda (g598)
- (if (not (g389 g598))
- (g391 (map (lambda (g599)
- (g393 g599 g589))
- g598)
- (g394 g590 g589 g588)
- '"bound variable")
- ((lambda (g601 g600)
- ((lambda (g603 g602)
- (g191 g588
- g600
- (map (lambda (g606)
- (g432 g606
- g602
- g603))
- g596)
- (g437 (cons g594 g595)
- (g394 g590
- g603
- g588)
- g602
- g603)))
- (g368 g598 g601 g589)
- (g248 g601 g600 g587)))
- (g299 g598)
- (map g451 g598))))
- g593))
- g592)
- ((lambda (g608)
- (syntax-error (g394 g590 g589 g588)))
- g591)))
- ($syntax-dispatch
- g591
- '(any #(each (any any)) any . each-any))))
- g590)))
- (g254 'core
- 'if
- (lambda (g770 g767 g769 g768)
- ((lambda (g771)
- ((lambda (g772)
- (if g772
- (apply
- (lambda (g775 g773 g774)
- (list 'if
- (g432 g773 g767 g769)
- (g432 g774 g767 g769)
- (g446)))
- g772)
- ((lambda (g776)
- (if g776
- (apply
- (lambda (g780 g777 g779 g778)
- (list 'if
- (g432 g777 g767 g769)
- (g432 g779 g767 g769)
- (g432 g778 g767 g769)))
- g776)
- ((lambda (g781)
- (syntax-error
- (g394 g770 g769 g768)))
- g771)))
- ($syntax-dispatch
- g771
- '(any any any any)))))
- ($syntax-dispatch g771 '(any any any))))
- g770)))
- (g254 'set! 'set! '())
- (g254 'begin 'begin '())
- (g254 'module-key 'module '())
- (g254 'import 'import '#f)
- (g254 'import 'import-only '#t)
- (g254 'define 'define '())
- (g254 'define-syntax 'define-syntax '())
- (g254 'eval-when 'eval-when '())
- (g254 'core
- 'syntax-case
- ((lambda ()
- (letrec ((g612
- (lambda (g693 g690 g692 g691)
- (if (null? g692)
- (list 'syntax-error g693)
- ((lambda (g694)
- ((lambda (g695)
- (if g695
- (apply
- (lambda (g697 g696)
- (if (if (g256 g697)
- (if (not (g392 g697
- g690))
- (not (g447 g697))
- '#f)
- '#f)
- ((lambda (g699 g698)
- (list (list 'lambda
- (list g698)
- (g432 g696
- (g246 g699
- (g231 'syntax
- (cons g698
- '0))
- g691)
- (g368 (list g697)
- (list g699)
- '(()))))
- g693))
- (g297)
- (g451 g697))
- (g611 g693
- g690
- (cdr g692)
- g691
- g697
- '#t
- g696)))
- g695)
- ((lambda (g700)
- (if g700
- (apply
- (lambda (g703
- g701
- g702)
- (g611 g693
- g690
- (cdr g692)
- g691
- g703
- g701
- g702))
- g700)
- ((lambda (g704)
- (syntax-error
- (car g692)
- '"invalid syntax-case clause"))
- g694)))
- ($syntax-dispatch
- g694
- '(any any any)))))
- ($syntax-dispatch
- g694
- '(any any))))
- (car g692)))))
- (g611
- (lambda (g635 g629 g634 g630 g633 g631 g632)
- (call-with-values
- (lambda () (g609 g633 g629))
- (lambda (g637 g636)
- (if (not (g390 (map car g636)))
- (g391 (map car g636)
- g633
- '"pattern variable")
- (if (not (andmap
- (lambda (g638)
- (not (g447 (car g638))))
- g636))
- (syntax-error
- g633
- '"misplaced ellipsis in syntax-case pattern")
- ((lambda (g639)
- (list (list 'lambda
- (list g639)
- (list 'if
- ((lambda (g649)
- ((lambda (g650)
- (if g650
- (apply
- (lambda ()
- g639)
- g650)
- ((lambda (g651)
- (list 'if
- g639
- (g610 g636
- g631
- g639
- g630)
- (list 'quote
- '#f)))
- g649)))
- ($syntax-dispatch
- g649
- '#(atom
- #t))))
- g631)
- (g610 g636
- g632
- g639
- g630)
- (g612 g635
- g629
- g634
- g630)))
- (if (eq? g637 'any)
- (list 'list g635)
- (list '$syntax-dispatch
- g635
- (list 'quote
- g637)))))
- (g451 'tmp))))))))
- (g610
- (lambda (g683 g680 g682 g681)
- ((lambda (g685 g684)
- ((lambda (g687 g686)
- (list 'apply
- (list 'lambda
- g686
- (g432 g680
- (g247 g687
- (map (lambda (g689
- g688)
- (g231 'syntax
- (cons g689
- g688)))
- g686
- (map cdr
- g683))
- g681)
- (g368 g685
- g687
- '(()))))
- g682))
- (g299 g685)
- (map g451 g685)))
- (map car g683)
- (map cdr g683))))
- (g609
- (lambda (g653 g652)
- ((letrec ((g654
- (lambda (g657 g655 g656)
- (if (g256 g657)
- (if (g392 g657 g652)
- (values
- (vector
- 'free-id
- g657)
- g656)
- (values
- 'any
- (cons (cons g657
- g655)
- g656)))
- ((lambda (g658)
- ((lambda (g659)
- (if (if g659
- (apply
- (lambda (g661
- g660)
- (g447 g660))
- g659)
- '#f)
- (apply
- (lambda (g663
- g662)
- (call-with-values
- (lambda ()
- (g654 g663
- (+ g655
- '1)
- g656))
- (lambda (g665
- g664)
- (values
- (if (eq? g665
- 'any)
- 'each-any
- (vector
- 'each
- g665))
- g664))))
- g659)
- ((lambda (g666)
- (if g666
- (apply
- (lambda (g668
- g667)
- (call-with-values
- (lambda ()
- (g654 g667
- g655
- g656))
- (lambda (g670
- g669)
- (call-with-values
- (lambda ()
- (g654 g668
- g655
- g669))
- (lambda (g672
- g671)
- (values
- (cons g672
- g670)
- g671))))))
- g666)
- ((lambda (g673)
- (if g673
- (apply
- (lambda ()
- (values
- '()
- g656))
- g673)
- ((lambda (g674)
- (if g674
- (apply
- (lambda (g675)
- (call-with-values
- (lambda ()
- (g654 g675
- g655
- g656))
- (lambda (g677
- g676)
- (values
- (vector
- 'vector
- g677)
- g676))))
- g674)
- ((lambda (g679)
- (values
- (vector
- 'atom
- (g450 g657
- '(())))
- g656))
- g658)))
- ($syntax-dispatch
- g658
- '#(vector
- each-any)))))
- ($syntax-dispatch
- g658
- '()))))
- ($syntax-dispatch
- g658
- '(any .
- any)))))
- ($syntax-dispatch
- g658
- '(any any))))
- g657)))))
- g654)
- g653
- '0
- '()))))
- (lambda (g616 g613 g615 g614)
- ((lambda (g617)
- ((lambda (g618)
- ((lambda (g619)
- (if g619
- (apply
- (lambda (g623 g620 g622 g621)
- (if (andmap
- (lambda (g625)
- (if (g256 g625)
- (not (g447 g625))
- '#f))
- g622)
- ((lambda (g626)
- (list (list 'lambda
- (list g626)
- (g612 g626
- g622
- g621
- g613))
- (g432 g620
- g613
- '(()))))
- (g451 'tmp))
- (syntax-error
- g617
- '"invalid literals list in")))
- g619)
- (syntax-error g618)))
- ($syntax-dispatch
- g618
- '(any any each-any . each-any))))
- g617))
- (g394 g616 g615 g614)))))))
- (set! sc-expand
- ((lambda (g763 g761 g762)
- ((lambda (g764)
- (lambda (g765)
- (if (if (pair? g765) (equal? (car g765) g53) '#f)
- (cadr g765)
- (g400 g765 '() g764 g763 g761 g762))))
- (g263 (g264 '((top))) (cons g762 (g265 '((top)))))))
- 'e
- '(eval)
- ((lambda (g766) (begin (g366 g766 '*top*) g766))
- (g304 '() '() '()))))
- (set! identifier? (lambda (g705) (g255 g705)))
- (set! datum->syntax-object
- (lambda (g759 g758)
- (begin ((lambda (g760)
- (if (not (g255 g760))
- (g93 'datum->syntax-object
- '"invalid argument"
- g760)
- (void)))
- g759)
- (g203 g758 (g206 g759)))))
- (set! syntax-object->datum
- (lambda (g706) (g450 g706 '(()))))
- (set! generate-temporaries
- (lambda (g755)
- (begin ((lambda (g757)
- (if (not (list? g757))
- (g93 'generate-temporaries
- '"invalid argument"
- g757)
- (void)))
- g755)
- (map (lambda (g756) (g393 (gensym) '((top))))
- g755))))
- (set! free-identifier=?
- (lambda (g708 g707)
- (begin ((lambda (g710)
- (if (not (g255 g710))
- (g93 'free-identifier=?
- '"invalid argument"
- g710)
- (void)))
- g708)
- ((lambda (g709)
- (if (not (g255 g709))
- (g93 'free-identifier=?
- '"invalid argument"
- g709)
- (void)))
- g707)
- (g378 g708 g707))))
- (set! bound-identifier=?
- (lambda (g752 g751)
- (begin ((lambda (g754)
- (if (not (g255 g754))
- (g93 'bound-identifier=?
- '"invalid argument"
- g754)
- (void)))
- g752)
- ((lambda (g753)
- (if (not (g255 g753))
- (g93 'bound-identifier=?
- '"invalid argument"
- g753)
- (void)))
- g751)
- (g388 g752 g751))))
- (set! syntax-error
- (lambda (g711 . g712)
- (begin (for-each
- (lambda (g714)
- ((lambda (g715)
- (if (not (string? g715))
- (g93 'syntax-error
- '"invalid argument"
- g715)
- (void)))
- g714))
- g712)
- ((lambda (g713) (g93 '#f g713 (g450 g711 '(()))))
- (if (null? g712)
- '"invalid syntax"
- (apply string-append g712))))))
- ((lambda ()
- (letrec ((g720
- (lambda (g748 g745 g747 g746)
- (if (not g746)
- '#f
- (if (eq? g745 'any)
- (cons (g393 g748 g747) g746)
- (if (g204 g748)
- (g719 ((lambda (g749)
- (if (g90 g749)
- (annotation-expression
- g749)
- g749))
- (g205 g748))
- g745
- (g371 g747 (g206 g748))
- g746)
- (g719 ((lambda (g750)
- (if (g90 g750)
- (annotation-expression
- g750)
- g750))
- g748)
- g745
- g747
- g746))))))
- (g719
- (lambda (g728 g725 g727 g726)
- (if (null? g725)
- (if (null? g728) g726 '#f)
- (if (pair? g725)
- (if (pair? g728)
- (g720 (car g728)
- (car g725)
- g727
- (g720 (cdr g728)
- (cdr g725)
- g727
- g726))
- '#f)
- (if (eq? g725 'each-any)
- ((lambda (g729)
- (if g729 (cons g729 g726) '#f))
- (g717 g728 g727))
- ((lambda (g730)
- (if (memv g730 '(each))
- (if (null? g728)
- (g718 (vector-ref
- g725
- '1)
- g726)
- ((lambda (g731)
- (if g731
- ((letrec ((g732
- (lambda (g733)
- (if (null?
- (car g733))
- g726
- (cons (map car
- g733)
- (g732 (map cdr
- g733)))))))
- g732)
- g731)
- '#f))
- (g716 g728
- (vector-ref
- g725
- '1)
- g727)))
- (if (memv g730 '(free-id))
- (if (g256 g728)
- (if (g378 (g393 g728
- g727)
- (vector-ref
- g725
- '1))
- g726
- '#f)
- '#f)
- (if (memv g730 '(atom))
- (if (equal?
- (vector-ref
- g725
- '1)
- (g450 g728
- g727))
- g726
- '#f)
- (if (memv g730
- '(vector))
- (if (vector?
- g728)
- (g720 (vector->list
- g728)
- (vector-ref
- g725
- '1)
- g727
- g726)
- '#f)
- (void))))))
- (vector-ref g725 '0)))))))
- (g718
- (lambda (g743 g742)
- (if (null? g743)
- g742
- (if (eq? g743 'any)
- (cons '() g742)
- (if (pair? g743)
- (g718 (car g743)
- (g718 (cdr g743) g742))
- (if (eq? g743 'each-any)
- (cons '() g742)
- ((lambda (g744)
- (if (memv g744 '(each))
- (g718 (vector-ref
- g743
- '1)
- g742)
- (if (memv g744
- '(free-id
- atom))
- g742
- (if (memv g744
- '(vector))
- (g718 (vector-ref
- g743
- '1)
- g742)
- (void)))))
- (vector-ref g743 '0))))))))
- (g717
- (lambda (g735 g734)
- (if (g90 g735)
- (g717 (annotation-expression g735) g734)
- (if (pair? g735)
- ((lambda (g736)
- (if g736
- (cons (g393 (car g735) g734)
- g736)
- '#f))
- (g717 (cdr g735) g734))
- (if (null? g735)
- '()
- (if (g204 g735)
- (g717 (g205 g735)
- (g371 g734 (g206 g735)))
- '#f))))))
- (g716
- (lambda (g739 g737 g738)
- (if (g90 g739)
- (g716 (annotation-expression g739)
- g737
- g738)
- (if (pair? g739)
- ((lambda (g740)
- (if g740
- ((lambda (g741)
- (if g741
- (cons g740 g741)
- '#f))
- (g716 (cdr g739) g737 g738))
- '#f))
- (g720 (car g739) g737 g738 '()))
- (if (null? g739)
- '()
- (if (g204 g739)
- (g716 (g205 g739)
- g737
- (g371 g738 (g206 g739)))
- '#f)))))))
- (set! $syntax-dispatch
- (lambda (g722 g721)
- (if (eq? g721 'any)
- (list g722)
- (if (g204 g722)
- (g719 ((lambda (g723)
- (if (g90 g723)
- (annotation-expression g723)
- g723))
- (g205 g722))
- g721
- (g206 g722)
- '())
- (g719 ((lambda (g724)
- (if (g90 g724)
- (annotation-expression g724)
- g724))
- g722)
- g721
- '(())
- '()))))))))))))
-($sc-put-cte
- 'with-syntax
- (lambda (g1828)
- ((lambda (g1829)
- ((lambda (g1830)
- (if g1830
- (apply
- (lambda (g1833 g1831 g1832)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(_ e1 e2)
- #((top) (top) (top))
- #("i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ())))
- (cons g1831 g1832)))
- g1830)
- ((lambda (g1835)
- (if g1835
- (apply
- (lambda (g1840 g1836 g1839 g1837 g1838)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g1839
- '()
- (list g1836
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g1837 g1838)))))
- g1835)
- ((lambda (g1842)
- (if g1842
- (apply
- (lambda (g1847 g1843 g1846 g1844 g1845)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons '#(syntax-object
- list
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g1846)
- '()
- (list g1843
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1844 g1845)))))
- g1842)
- (syntax-error g1829)))
- ($syntax-dispatch
- g1829
- '(any #(each (any any)) any . each-any)))))
- ($syntax-dispatch
- g1829
- '(any ((any any)) any . each-any)))))
- ($syntax-dispatch g1829 '(any () any . each-any))))
- g1828)))
-($sc-put-cte
- 'syntax-rules
- (lambda (g1851)
- ((lambda (g1852)
- ((lambda (g1853)
- (if g1853
- (apply
- (lambda (g1858 g1854 g1857 g1855 g1856)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ())))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ()))))
- (cons '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons '#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g1854
- (map (lambda (g1861 g1860)
- (list (cons '#(syntax-object
- dummy
- ((top)
- #(ribcage
- #(_
- k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1860)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1861)))
- g1856
- g1855))))))
- g1853)
- (syntax-error g1852)))
- ($syntax-dispatch
- g1852
- '(any each-any . #(each ((any . any) any))))))
- g1851)))
-($sc-put-cte
- 'or
- (lambda (g1862)
- ((lambda (g1863)
- ((lambda (g1864)
- (if g1864
- (apply
- (lambda (g1865)
- '#(syntax-object
- #f
- ((top)
- #(ribcage #(_) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ()))))
- g1864)
- ((lambda (g1866)
- (if g1866
- (apply (lambda (g1868 g1867) g1867) g1866)
- ((lambda (g1869)
- (if g1869
- (apply
- (lambda (g1873 g1870 g1872 g1871)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1870))
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons '#(syntax-object
- or
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1872 g1871)))))
- g1869)
- (syntax-error g1863)))
- ($syntax-dispatch g1863 '(any any any . each-any)))))
- ($syntax-dispatch g1863 '(any any)))))
- ($syntax-dispatch g1863 '(any))))
- g1862)))
-($sc-put-cte
- 'and
- (lambda (g1875)
- ((lambda (g1876)
- ((lambda (g1877)
- (if g1877
- (apply
- (lambda (g1881 g1878 g1880 g1879)
- (cons '#(syntax-object
- if
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ())))
- (cons g1878
- (cons (cons '#(syntax-object
- and
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g1880 g1879))
- '(#(syntax-object
- #f
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))))))
- g1877)
- ((lambda (g1883)
- (if g1883
- (apply (lambda (g1885 g1884) g1884) g1883)
- ((lambda (g1886)
- (if g1886
- (apply
- (lambda (g1887)
- '#(syntax-object
- #t
- ((top)
- #(ribcage #(_) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- g1886)
- (syntax-error g1876)))
- ($syntax-dispatch g1876 '(any)))))
- ($syntax-dispatch g1876 '(any any)))))
- ($syntax-dispatch g1876 '(any any any . each-any))))
- g1875)))
-($sc-put-cte
- 'let
- (lambda (g1888)
- ((lambda (g1889)
- ((lambda (g1890)
- (if (if g1890
- (apply
- (lambda (g1895 g1891 g1894 g1892 g1893)
- (andmap identifier? g1891))
- g1890)
- '#f)
- (apply
- (lambda (g1901 g1897 g1900 g1898 g1899)
- (cons (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ x v e1 e2)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g1897 (cons g1898 g1899)))
- g1900))
- g1890)
- ((lambda (g1905)
- (if (if g1905
- (apply
- (lambda (g1911 g1906 g1910 g1907 g1909 g1908)
- (andmap identifier? (cons g1906 g1910)))
- g1905)
- '#f)
- (apply
- (lambda (g1918 g1913 g1917 g1914 g1916 g1915)
- (cons (list '#(syntax-object
- letrec
- ((top)
- #(ribcage
- #(_ f x v e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (list (list g1913
- (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_
- f
- x
- v
- e1
- e2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1917
- (cons g1916
- g1915)))))
- g1913)
- g1914))
- g1905)
- (syntax-error g1889)))
- ($syntax-dispatch
- g1889
- '(any any #(each (any any)) any . each-any)))))
- ($syntax-dispatch
- g1889
- '(any #(each (any any)) any . each-any))))
- g1888)))
-($sc-put-cte
- 'let*
- (lambda (g1922)
- ((lambda (g1923)
- ((lambda (g1924)
- (if (if g1924
- (apply
- (lambda (g1929 g1925 g1928 g1926 g1927)
- (andmap identifier? g1925))
- g1924)
- '#f)
- (apply
- (lambda (g1935 g1931 g1934 g1932 g1933)
- ((letrec ((g1936
- (lambda (g1937)
- (if (null? g1937)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(bindings)
- #((top))
- #("i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(let* x v e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons '() (cons g1932 g1933)))
- ((lambda (g1939)
- ((lambda (g1940)
- (if g1940
- (apply
- (lambda (g1942 g1941)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(body
- binding)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(bindings)
- #((top))
- #("i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(let*
- x
- v
- e1
- e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list g1941)
- g1942))
- g1940)
- (syntax-error g1939)))
- ($syntax-dispatch
- g1939
- '(any any))))
- (list (g1936 (cdr g1937))
- (car g1937)))))))
- g1936)
- (map list g1931 g1934)))
- g1924)
- (syntax-error g1923)))
- ($syntax-dispatch
- g1923
- '(any #(each (any any)) any . each-any))))
- g1922)))
-($sc-put-cte
- 'cond
- (lambda (g1945)
- ((lambda (g1946)
- ((lambda (g1947)
- (if g1947
- (apply
- (lambda (g1950 g1948 g1949)
- ((letrec ((g1951
- (lambda (g1953 g1952)
- (if (null? g1952)
- ((lambda (g1954)
- ((lambda (g1955)
- (if g1955
- (apply
- (lambda (g1957 g1956)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_ m1 m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1957 g1956)))
- g1955)
- ((lambda (g1959)
- (if g1959
- (apply
- (lambda (g1960)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1960))
- '((#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))))))
- g1959)
- ((lambda (g1961)
- (if g1961
- (apply
- (lambda (g1963
- g1962)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1963))
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1962
- '(#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))))))
- g1961)
- ((lambda (g1964)
- (if g1964
- (apply
- (lambda (g1967
- g1965
- g1966)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1967
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e0
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1965
- g1966))))
- g1964)
- ((lambda (g1969)
- (syntax-error
- g1945))
- g1954)))
- ($syntax-dispatch
- g1954
- '(any any
- .
- each-any)))))
- ($syntax-dispatch
- g1954
- '(any #(free-id
- #(syntax-object
- =>
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- any)))))
- ($syntax-dispatch
- g1954
- '(any)))))
- ($syntax-dispatch
- g1954
- '(#(free-id
- #(syntax-object
- else
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(clause clauses)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_ m1 m2)
- #((top) (top) (top))
- #("i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- any
- .
- each-any))))
- g1953)
- ((lambda (g1970)
- ((lambda (g1971)
- ((lambda (g1972)
- ((lambda (g1973)
- (if g1973
- (apply
- (lambda (g1974)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1974))
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1971)))
- g1973)
- ((lambda (g1975)
- (if g1975
- (apply
- (lambda (g1977
- g1976)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1977))
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1976
- '(#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))))
- g1971)))
- g1975)
- ((lambda (g1978)
- (if g1978
- (apply
- (lambda (g1981
- g1979
- g1980)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1981
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e0
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1979
- g1980))
- g1971))
- g1978)
- ((lambda (g1983)
- (syntax-error
- g1945))
- g1972)))
- ($syntax-dispatch
- g1972
- '(any any
- .
- each-any)))))
- ($syntax-dispatch
- g1972
- '(any #(free-id
- #(syntax-object
- =>
- ((top)
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- any)))))
- ($syntax-dispatch
- g1972
- '(any))))
- g1953))
- g1970))
- (g1951 (car g1952) (cdr g1952)))))))
- g1951)
- g1948
- g1949))
- g1947)
- (syntax-error g1946)))
- ($syntax-dispatch g1946 '(any any . each-any))))
- g1945)))
-($sc-put-cte
- 'do
- (lambda (g1985)
- ((lambda (g1986)
- ((lambda (g1987)
- (if g1987
- (apply
- (lambda (g1994 g1988 g1993 g1989 g1992 g1990 g1991)
- ((lambda (g1995)
- ((lambda (g2005)
- (if g2005
- (apply
- (lambda (g2006)
- ((lambda (g2007)
- ((lambda (g2009)
- (if g2009
- (apply
- (lambda ()
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (map list g1988 g1993)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- not
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1992)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (append
- g1991
- (list (cons '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2006)))))))
- g2009)
- ((lambda (g2014)
- (if g2014
- (apply
- (lambda (g2016 g2015)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e1 e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1 e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (map list
- g1988
- g1993)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1992
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2016
- g2015))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (append
- g1991
- (list (cons '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2006)))))))
- g2014)
- (syntax-error g2007)))
- ($syntax-dispatch
- g2007
- '(any . each-any)))))
- ($syntax-dispatch g2007 '())))
- g1990))
- g2005)
- (syntax-error g1995)))
- ($syntax-dispatch g1995 'each-any)))
- (map (lambda (g1999 g1998)
- ((lambda (g2000)
- ((lambda (g2001)
- (if g2001
- (apply (lambda () g1999) g2001)
- ((lambda (g2002)
- (if g2002
- (apply
- (lambda (g2003) g2003)
- g2002)
- ((lambda (g2004)
- (syntax-error g1985))
- g2000)))
- ($syntax-dispatch g2000 '(any)))))
- ($syntax-dispatch g2000 '())))
- g1998))
- g1988
- g1989)))
- g1987)
- (syntax-error g1986)))
- ($syntax-dispatch
- g1986
- '(any #(each (any any . any))
- (any . each-any)
- .
- each-any))))
- g1985)))
-($sc-put-cte
- 'quasiquote
- (letrec ((g2030
- (lambda (g2142)
- (if (identifier? g2142)
- (free-identifier=?
- g2142
- '#(syntax-object
- quote
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ()))))
- '#f)))
- (g2022
- (lambda (g2036)
- (if (identifier? g2036)
- (free-identifier=?
- g2036
- '#(syntax-object
- list
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ()))))
- '#f)))
- (g2029
- (lambda (g2141)
- (if (identifier? g2141)
- (free-identifier=?
- g2141
- '#(syntax-object
- cons
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ()))))
- '#f)))
- (g2023
- (lambda (g2037)
- ((lambda (g2038)
- ((lambda (g2039)
- (if g2039
- (apply (lambda (g2040) (g2030 g2040)) g2039)
- ((lambda (g2041) '#f) g2038)))
- ($syntax-dispatch g2038 '(any ()))))
- g2037)))
- (g2028
- (lambda (g2138 g2137)
- ((letrec ((g2139
- (lambda (g2140)
- (if (null? g2140)
- g2137
- (g2024 (car g2140) (g2139 (cdr g2140)))))))
- g2139)
- g2138)))
- (g2024
- (lambda (g2043 g2042)
- ((lambda (g2044)
- ((lambda (g2045)
- (if g2045
- (apply
- (lambda (g2047 g2046)
- ((lambda (g2048)
- ((lambda (g2049)
- (if (if g2049
- (apply
- (lambda (g2051 g2050)
- (g2030 g2051))
- g2049)
- '#f)
- (apply
- (lambda (g2053 g2052)
- ((lambda (g2054)
- ((lambda (g2055)
- (if (if g2055
- (apply
- (lambda (g2057
- g2056)
- (g2030 g2057))
- g2055)
- '#f)
- (apply
- (lambda (g2059 g2058)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(quote?
- dx)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(quote?
- dy)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(x y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2058
- g2052)))
- g2055)
- ((lambda (g2060)
- (if (null? g2052)
- (list '#(syntax-object
- list
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(quote?
- dy)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2047)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(quote?
- dy)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2047
- g2046)))
- g2054)))
- ($syntax-dispatch
- g2054
- '(any any))))
- g2047))
- g2049)
- ((lambda (g2061)
- (if (if g2061
- (apply
- (lambda (g2063 g2062)
- (g2022 g2063))
- g2061)
- '#f)
- (apply
- (lambda (g2065 g2064)
- (cons '#(syntax-object
- list
- ((top)
- #(ribcage
- #(listp stuff)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2047 g2064)))
- g2061)
- ((lambda (g2066)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage
- #(else)
- #((top))
- #("i"))
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2047
- g2046))
- g2048)))
- ($syntax-dispatch
- g2048
- '(any . any)))))
- ($syntax-dispatch g2048 '(any any))))
- g2046))
- g2045)
- (syntax-error g2044)))
- ($syntax-dispatch g2044 '(any any))))
- (list g2043 g2042))))
- (g2027
- (lambda (g2129 g2128)
- ((lambda (g2130)
- (if (null? g2130)
- '(#(syntax-object
- quote
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(ls) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x y) #((top) (top)) #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ())))
- ())
- (if (null? (cdr g2130))
- (car g2130)
- ((lambda (g2131)
- ((lambda (g2132)
- (if g2132
- (apply
- (lambda (g2133)
- (cons '#(syntax-object
- append
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ls)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2133))
- g2132)
- (syntax-error g2131)))
- ($syntax-dispatch g2131 'each-any)))
- g2130))))
- ((letrec ((g2135
- (lambda (g2136)
- (if (null? g2136)
- (if (g2023 g2128) '() (list g2128))
- (if (g2023 (car g2136))
- (g2135 (cdr g2136))
- (cons (car g2136)
- (g2135 (cdr g2136))))))))
- g2135)
- g2129))))
- (g2025
- (lambda (g2067)
- ((lambda (g2068)
- ((lambda (g2069)
- ((lambda (g2070)
- ((lambda (g2071)
- (if (if g2071
- (apply
- (lambda (g2073 g2072) (g2030 g2073))
- g2071)
- '#f)
- (apply
- (lambda (g2075 g2074)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(quote? x)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(pat-x)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (list->vector g2074)))
- g2071)
- ((lambda (g2077)
- ((letrec ((g2078
- (lambda (g2080 g2079)
- ((lambda (g2081)
- ((lambda (g2082)
- (if (if g2082
- (apply
- (lambda (g2084
- g2083)
- (g2030
- g2084))
- g2082)
- '#f)
- (apply
- (lambda (g2086
- g2085)
- (g2079
- (map (lambda (g2087)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(quote?
- x)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- k)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(pat-x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2087))
- g2085)))
- g2082)
- ((lambda (g2088)
- (if (if g2088
- (apply
- (lambda (g2090
- g2089)
- (g2022
- g2090))
- g2088)
- '#f)
- (apply
- (lambda (g2092
- g2091)
- (g2079
- g2091))
- g2088)
- ((lambda (g2094)
- (if (if g2094
- (apply
- (lambda (g2097
- g2095
- g2096)
- (g2029
- g2097))
- g2094)
- '#f)
- (apply
- (lambda (g2100
- g2098
- g2099)
- (g2078
- g2099
- (lambda (g2101)
- (g2079
- (cons g2098
- g2101)))))
- g2094)
- ((lambda (g2102)
- (list '#(syntax-object
- list->vector
- ((top)
- #(ribcage
- #(else)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- k)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(pat-x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2069))
- g2081)))
- ($syntax-dispatch
- g2081
- '(any any
- any)))))
- ($syntax-dispatch
- g2081
- '(any .
- each-any)))))
- ($syntax-dispatch
- g2081
- '(any each-any))))
- g2080))))
- g2078)
- g2067
- (lambda (g2103)
- (cons '#(syntax-object
- vector
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ls)
- #((top))
- #("i"))
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(pat-x)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2103))))
- g2070)))
- ($syntax-dispatch g2070 '(any each-any))))
- g2069))
- g2068))
- g2067)))
- (g2026
- (lambda (g2105 g2104)
- ((lambda (g2106)
- ((lambda (g2107)
- (if g2107
- (apply
- (lambda (g2108)
- (if (= g2104 '0)
- g2108
- (g2024
- '(#(syntax-object
- quote
- ((top)
- #(ribcage #(p) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- unquote
- ((top)
- #(ribcage #(p) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (g2026 (list g2108) (- g2104 '1)))))
- g2107)
- ((lambda (g2109)
- (if g2109
- (apply
- (lambda (g2111 g2110)
- (if (= g2104 '0)
- (g2028 g2111 (g2026 g2110 g2104))
- (g2024
- (g2024
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- unquote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (g2026 g2111 (- g2104 '1)))
- (g2026 g2110 g2104))))
- g2109)
- ((lambda (g2114)
- (if g2114
- (apply
- (lambda (g2116 g2115)
- (if (= g2104 '0)
- (g2027
- g2116
- (g2026 g2115 g2104))
- (g2024
- (g2024
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- (g2026
- g2116
- (- g2104 '1)))
- (g2026 g2115 g2104))))
- g2114)
- ((lambda (g2119)
- (if g2119
- (apply
- (lambda (g2120)
- (g2024
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- (g2026
- (list g2120)
- (+ g2104 '1))))
- g2119)
- ((lambda (g2121)
- (if g2121
- (apply
- (lambda (g2123 g2122)
- (g2024
- (g2026
- g2123
- g2104)
- (g2026
- g2122
- g2104)))
- g2121)
- ((lambda (g2124)
- (if g2124
- (apply
- (lambda (g2125)
- (g2025
- (g2026
- g2125
- g2104)))
- g2124)
- ((lambda (g2127)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(p
- lev)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2127))
- g2106)))
- ($syntax-dispatch
- g2106
- '#(vector
- each-any)))))
- ($syntax-dispatch
- g2106
- '(any . any)))))
- ($syntax-dispatch
- g2106
- '(#(free-id
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- any)))))
- ($syntax-dispatch
- g2106
- '((#(free-id
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- .
- each-any)
- .
- any)))))
- ($syntax-dispatch
- g2106
- '((#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- .
- each-any)
- .
- any)))))
- ($syntax-dispatch
- g2106
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage () () ())
- #(ribcage #(p lev) #((top) (top)) #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ()))))
- any))))
- g2105))))
- (lambda (g2031)
- ((lambda (g2032)
- ((lambda (g2033)
- (if g2033
- (apply (lambda (g2035 g2034) (g2026 g2034 '0)) g2033)
- (syntax-error g2032)))
- ($syntax-dispatch g2032 '(any any))))
- g2031))))
-($sc-put-cte
- 'include
- (lambda (g2143)
- (letrec ((g2144
- (lambda (g2155 g2154)
- ((lambda (g2156)
- ((letrec ((g2157
- (lambda ()
- ((lambda (g2158)
- (if (eof-object? g2158)
- (begin (close-input-port g2156) '())
- (cons (datum->syntax-object
- g2154
- g2158)
- (g2157))))
- (read g2156)))))
- g2157)))
- (open-input-file g2155)))))
- ((lambda (g2145)
- ((lambda (g2146)
- (if g2146
- (apply
- (lambda (g2148 g2147)
- ((lambda (g2149)
- ((lambda (g2150)
- ((lambda (g2151)
- (if g2151
- (apply
- (lambda (g2152)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(exp)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(fn)
- #((top))
- #("i"))
- #(ribcage
- #(k filename)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- (read-file)
- ((top))
- ("i"))
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2152))
- g2151)
- (syntax-error g2150)))
- ($syntax-dispatch g2150 'each-any)))
- (g2144 g2149 g2148)))
- (syntax-object->datum g2147)))
- g2146)
- (syntax-error g2145)))
- ($syntax-dispatch g2145 '(any any))))
- g2143))))
-($sc-put-cte
- 'unquote
- (lambda (g2159)
- ((lambda (g2160)
- ((lambda (g2161)
- (if g2161
- (apply
- (lambda (g2163 g2162)
- (syntax-error
- g2159
- '"expression not valid outside of quasiquote"))
- g2161)
- (syntax-error g2160)))
- ($syntax-dispatch g2160 '(any . each-any))))
- g2159)))
-($sc-put-cte
- 'unquote-splicing
- (lambda (g2164)
- ((lambda (g2165)
- ((lambda (g2166)
- (if g2166
- (apply
- (lambda (g2168 g2167)
- (syntax-error
- g2164
- '"expression not valid outside of quasiquote"))
- g2166)
- (syntax-error g2165)))
- ($syntax-dispatch g2165 '(any . each-any))))
- g2164)))
-($sc-put-cte
- 'case
- (lambda (g2169)
- ((lambda (g2170)
- ((lambda (g2171)
- (if g2171
- (apply
- (lambda (g2175 g2172 g2174 g2173)
- ((lambda (g2176)
- ((lambda (g2203)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage #(body) #((top)) #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(body)
- #((top))
- #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2172))
- g2203))
- g2176))
- ((letrec ((g2177
- (lambda (g2179 g2178)
- (if (null? g2178)
- ((lambda (g2180)
- ((lambda (g2181)
- (if g2181
- (apply
- (lambda (g2183 g2182)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2183
- g2182)))
- g2181)
- ((lambda (g2185)
- (if g2185
- (apply
- (lambda (g2188
- g2186
- g2187)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2188))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2186
- g2187))))
- g2185)
- ((lambda (g2191)
- (syntax-error
- g2169))
- g2180)))
- ($syntax-dispatch
- g2180
- '(each-any
- any
- .
- each-any)))))
- ($syntax-dispatch
- g2180
- '(#(free-id
- #(syntax-object
- else
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(clause clauses)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- any
- .
- each-any))))
- g2179)
- ((lambda (g2192)
- ((lambda (g2193)
- ((lambda (g2194)
- ((lambda (g2195)
- (if g2195
- (apply
- (lambda (g2198
- g2196
- g2197)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2198))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2196
- g2197))
- g2193))
- g2195)
- ((lambda (g2201)
- (syntax-error
- g2169))
- g2194)))
- ($syntax-dispatch
- g2194
- '(each-any
- any
- .
- each-any))))
- g2179))
- g2192))
- (g2177 (car g2178) (cdr g2178)))))))
- g2177)
- g2174
- g2173)))
- g2171)
- (syntax-error g2170)))
- ($syntax-dispatch g2170 '(any any any . each-any))))
- g2169)))
-($sc-put-cte
- 'identifier-syntax
- (lambda (g2204)
- ((lambda (g2205)
- ((lambda (g2206)
- (if g2206
- (apply
- (lambda (g2208 g2207)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage #(_ e) #((top) (top)) #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ())))
- '(#(syntax-object
- x
- ((top)
- #(ribcage #(_ e) #((top) (top)) #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ()))))
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '()
- (list '#(syntax-object
- id
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '(#(syntax-object
- identifier?
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- id
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2207))
- (list (cons g2208
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g2207
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))))))))
- g2206)
- ((lambda (g2209)
- (if (if g2209
- (apply
- (lambda (g2215 g2210 g2214 g2211 g2213 g2212)
- (if (identifier? g2210)
- (identifier? g2211)
- '#f))
- g2209)
- '#f)
- (apply
- (lambda (g2221 g2216 g2220 g2217 g2219 g2218)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top) (top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- macro!
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '(#(syntax-object
- set!
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (list (list '#(syntax-object
- set!
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2217
- g2219)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2218))
- (list (cons g2216
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2220
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))))))
- (list g2216
- (list '#(syntax-object
- identifier?
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2216))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2220))))))
- g2209)
- (syntax-error g2205)))
- ($syntax-dispatch
- g2205
- '(any (any any)
- ((#(free-id
- #(syntax-object
- set!
- ((top)
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ()))))
- any
- any)
- any))))))
- ($syntax-dispatch g2205 '(any any))))
- g2204)))
+++ /dev/null
-;;; Portable implementation of syntax-case
-;;; Extracted from Chez Scheme Version 6.3
-;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
-
-;;; Copyright (c) 1992-2000 Cadence Research Systems
-;;; Permission to copy this software, in whole or in part, to use this
-;;; software for any lawful purpose, and to redistribute this software
-;;; is granted subject to the restriction that all copies made of this
-;;; software must include this copyright notice in full. This software
-;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
-;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
-;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
-;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
-;;; NATURE WHATSOEVER.
-
-;;; Before attempting to port this code to a new implementation of
-;;; Scheme, please read the notes below carefully.
-
-;;; This file defines the syntax-case expander, sc-expand, and a set
-;;; of associated syntactic forms and procedures. Of these, the
-;;; following are documented in The Scheme Programming Language,
-;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996), which can be
-;;; found online at http://www.scheme.com. Most are also documented
-;;; in the R4RS and draft R5RS.
-;;;
-;;; bound-identifier=?
-;;; datum->syntax-object
-;;; define-syntax
-;;; fluid-let-syntax
-;;; free-identifier=?
-;;; generate-temporaries
-;;; identifier?
-;;; identifier-syntax
-;;; let-syntax
-;;; letrec-syntax
-;;; syntax
-;;; syntax-case
-;;; syntax-object->datum
-;;; syntax-rules
-;;; with-syntax
-;;;
-;;; All standard Scheme syntactic forms are supported by the expander
-;;; or syntactic abstractions defined in this file. Only the R4RS
-;;; delay is omitted, since its expansion is implementation-dependent.
-
-;;; Also defined are three forms that support modules: module, import,
-;;; and import-only. These are documented in the Chez Scheme User's
-;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
-;;; also be found online at http://www.scheme.com. They are described
-;;; briefly here as well.
-;;;
-;;; Both are definitions and may appear where and only where other
-;;; definitions may appear. modules may be named:
-;;;
-;;; (module id (ex ...) defn ... init ...)
-;;;
-;;; or anonymous:
-;;;
-;;; (module (ex ...) defn ... init ...)
-;;;
-;;; The latter form is semantically equivalent to:
-;;;
-;;; (module T (ex ...) defn ... init ...)
-;;; (import T)
-;;;
-;;; where T is a fresh identifier.
-;;;
-;;; In either form, each of the exports in (ex ...) is either an
-;;; identifier or of the form (id ex ...). In the former case, the
-;;; single identifier ex is exported. In the latter, the identifier
-;;; id is exported and the exports ex ... are "implicitly" exported.
-;;; This listing of implicit exports is useful only when id is a
-;;; keyword bound to a transformer that expands into references to
-;;; the listed implicit exports. In the present implementation,
-;;; listing of implicit exports is necessary only for top-level
-;;; modules and allows the implementation to avoid placing all
-;;; identifiers into the top-level environment where subsequent passes
-;;; of the compiler will be unable to deal effectively with them.
-;;;
-;;; Named modules may be referenced in import statements, which
-;;; always take one of the forms:
-;;;
-;;; (import id)
-;;; (import-only id)
-;;;
-;;; id must name a module. Each exported identifier becomes visible
-;;; within the scope of the import form. In the case of import-only,
-;;; all other identifiers become invisible in the scope of the
-;;; import-only form, except for those established by definitions
-;;; that appear textually after the import-only form.
-
-;;; The remaining exports are listed below. sc-expand, eval-when, and
-;;; syntax-error are described in the Chez Scheme User's Guide.
-;;;
-;;; (sc-expand datum)
-;;; if datum represents a valid expression, sc-expand returns an
-;;; expanded version of datum in a core language that includes no
-;;; syntactic abstractions. The core language includes begin,
-;;; define, if, lambda, letrec, quote, and set!.
-;;; (eval-when situations expr ...)
-;;; conditionally evaluates expr ... at compile-time or run-time
-;;; depending upon situations
-;;; (syntax-error object message)
-;;; used to report errors found during expansion
-;;; ($syntax-dispatch e p)
-;;; used by expanded code to handle syntax-case matching
-;;; ($sc-put-cte symbol val)
-;;; used to establish top-level compile-time (expand-time) bindings.
-
-;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value". The
-;;; following usually works:
-;;;
-;;; (define void (lambda () (if #f #f))).
-;;;
-;;; (andmap proc list1 list2 ...)
-;;; returns true if proc returns true when applied to each element of list1
-;;; along with the corresponding elements of list2 .... The following
-;;; definition works but does no error checking:
-;;;
-;;; (define andmap
-;;; (lambda (f first . rest)
-;;; (or (null? first)
-;;; (if (null? rest)
-;;; (let andmap ((first first))
-;;; (let ((x (car first)) (first (cdr first)))
-;;; (if (null? first)
-;;; (f x)
-;;; (and (f x) (andmap first)))))
-;;; (let andmap ((first first) (rest rest))
-;;; (let ((x (car first))
-;;; (xr (map car rest))
-;;; (first (cdr first))
-;;; (rest (map cdr rest)))
-;;; (if (null? first)
-;;; (apply f (cons x xr))
-;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
-;;;
-;;; (ormap proc list1)
-;;; returns the first non-false return result of proc applied to
-;;; the elements of list1 or false if none. The following definition
-;;; works but does no error checking:
-;;;
-;;; (define ormap
-;;; (lambda (proc list1)
-;;; (and (not (null? list1))
-;;; (or (proc (car list1)) (ormap proc (cdr list1))))))
-;;;
-;;; The following nonstandard procedures must also be provided by the
-;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors. They are not used by expanded code,
-;;; and so need be present only at expansion time.
-;;;
-;;; (eval x)
-;;; where x is always in the form ("noexpand" expr).
-;;; returns the value of expr. the "noexpand" flag is used to tell the
-;;; evaluator/expander that no expansion is necessary, since expr has
-;;; already been fully expanded to core forms.
-;;;
-;;; eval will not be invoked during the loading of psyntax.pp. After
-;;; psyntax.pp has been loaded, the expansion of any macro definition,
-;;; whether local or global, results in a call to eval. If, however,
-;;; sc-expand has already been registered as the expander to be used
-;;; by eval, and eval accepts one argument, nothing special must be done
-;;; to support the "noexpand" flag, since it is handled by sc-expand.
-;;;
-;;; (error who format-string why what)
-;;; where who is either a symbol or #f, format-string is always "~a ~s",
-;;; why is always a string, and what may be any object. error should
-;;; signal an error with a message something like
-;;;
-;;; "error in <who>: <why> <what>"
-;;;
-;;; (gensym)
-;;; returns a unique symbol each time it's called. In Chez Scheme, gensym
-;;; returns a symbol with a "globally" unique name so that gensyms that
-;;; end up in the object code of separately compiled files cannot conflict.
-;;; This is necessary only if you intend to support compiled files.
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; (remprop symbol key)
-;;; key is always a symbol; value may be any object. putprop should
-;;; associate the given value with the given symbol and key in some way
-;;; that it can be retrieved later with getprop. getprop should return
-;;; #f if no value is associated with the given symbol and key. remprop
-;;; should remove the association between the given symbol and key.
-
-;;; When porting to a new Scheme implementation, you should define the
-;;; procedures listed above, load the expanded version of psyntax.ss
-;;; (psyntax.pp, which should be available whereever you found
-;;; psyntax.ss), and register sc-expand as the current expander (how
-;;; you do this depends upon your implementation of Scheme). You may
-;;; change the hooks and constructors defined toward the beginning of
-;;; the code below, but to avoid bootstrapping problems, do so only
-;;; after you have a working version of the expander.
-
-;;; Chez Scheme allows the syntactic form (syntax <template>) to be
-;;; abbreviated to #'<template>, just as (quote <datum>) may be
-;;; abbreviated to '<datum>. The #' syntax makes programs written
-;;; using syntax-case shorter and more readable and draws out the
-;;; intuitive connection between syntax and quote. If you have access
-;;; to the source code of your Scheme system's reader, you might want
-;;; to implement this extension.
-
-;;; If you find that this code loads or runs slowly, consider
-;;; switching to faster hardware or a faster implementation of
-;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
-;;; compiling (with full optimization), and loading this file takes
-;;; between one and two seconds.
-
-;;; In the expander implementation, we sometimes use syntactic abstractions
-;;; when procedural abstractions would suffice. For example, we define
-;;; top-wrap and top-marked? as
-;;; (define-syntax top-wrap (identifier-syntax '((top))))
-;;; (define-syntax top-marked?
-;;; (syntax-rules ()
-;;; ((_ w) (memq 'top (wrap-marks w)))))
-;;; rather than
-;;; (define top-wrap '((top)))
-;;; (define top-marked?
-;;; (lambda (w) (memq 'top (wrap-marks w))))
-;;; On ther other hand, we don't do this consistently; we define make-wrap,
-;;; wrap-marks, and wrap-subst simply as
-;;; (define make-wrap cons)
-;;; (define wrap-marks car)
-;;; (define wrap-subst cdr)
-;;; In Chez Scheme, the syntactic and procedural forms of these
-;;; abstractions are equivalent, since the optimizer consistently
-;;; integrates constants and small procedures. Some Scheme
-;;; implementations, however, may benefit from more consistent use
-;;; of one form or the other.
-
-
-;;; Implementation notes:
-
-;;; "begin" is treated as a splicing construct at top level and at
-;;; the beginning of bodies. Any sequence of expressions that would
-;;; be allowed where the "begin" occurs is allowed.
-
-;;; "let-syntax" and "letrec-syntax" are also treated as splicing
-;;; constructs, in violation of the R5RS. A consequence is that let-syntax
-;;; and letrec-syntax do not create local contours, as do let and letrec.
-;;; Although the functionality is greater as it is presently implemented,
-;;; we will probably change it to conform to the R5RS. modules provide
-;;; similar functionality to nonsplicing letrec-syntax when the latter is
-;;; used as a definition.
-
-;;; Objects with no standard print syntax, including objects containing
-;;; cycles and syntax objects, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
-;;; Such objects are never copied.
-
-;;; When the expander encounters a reference to an identifier that has
-;;; no global or lexical binding, it treats it as a global-variable
-;;; reference. This allows one to write mutually recursive top-level
-;;; definitions, e.g.:
-;;;
-;;; (define f (lambda (x) (g x)))
-;;; (define g (lambda (x) (f x)))
-;;;
-;;; but may not always yield the intended when the variable in question
-;;; is later defined as a keyword.
-
-;;; Top-level variable definitions of syntax keywords are permitted.
-;;; In order to make this work, top-level define not only produces a
-;;; top-level definition in the core language, but also modifies the
-;;; compile-time environment (using $sc-put-cte) to record the fact
-;;; that the identifier is a variable.
-
-;;; Top-level definitions of macro-introduced identifiers are visible
-;;; only in code produced by the macro. That is, a binding for a
-;;; hidden (generated) identifier is created instead, and subsequent
-;;; references within the macro output are renamed accordingly. For
-;;; example:
-;;;
-;;; (define-syntax a
-;;; (syntax-rules ()
-;;; ((_ var exp)
-;;; (begin
-;;; (define secret exp)
-;;; (define var
-;;; (lambda ()
-;;; (set! secret (+ secret 17))
-;;; secret))))))
-;;; (a x 0)
-;;; (x) => 17
-;;; (x) => 34
-;;; secret => Error: variable secret is not bound
-;;;
-;;; The definition above would fail if the definition for secret
-;;; were placed after the definition for var, since the expander would
-;;; encounter the references to secret before the definition that
-;;; establishes the compile-time map from the identifier secret to
-;;; the generated identifier.
-
-;;; Identifiers and syntax objects are implemented as vectors for
-;;; portability. As a result, it is possible to "forge" syntax
-;;; objects.
-
-;;; The input to sc-expand may contain "annotations" describing, e.g., the
-;;; source file and character position from where each object was read if
-;;; it was read from a file. These annotations are handled properly by
-;;; sc-expand only if the annotation? hook (see hooks below) is implemented
-;;; properly and the operators make-annotation, annotation-expression,
-;;; annotation-source, annotation-stripped, and set-annotation-stripped!
-;;; are supplied. If annotations are supplied, the proper annotation
-;;; source is passed to the various output constructors, allowing
-;;; implementations to accurately correlate source and expanded code.
-;;; Contact one of the authors for details if you wish to make use of
-;;; this feature.
-
-;;; Implementation of modules:
-;;;
-;;; The implementation of modules requires that implicit top-level exports
-;;; be listed with the exported macro at some level where both are visible,
-;;; e.g.,
-;;;
-;;; (module M (alpha (beta b))
-;;; (module ((alpha a) b)
-;;; (define-syntax alpha (identifier-syntax a))
-;;; (define a 'a)
-;;; (define b 'b))
-;;; (define-syntax beta (identifier-syntax b)))
-;;;
-;;; Listing of implicit imports is not needed for macros that do not make
-;;; it out to top level, including all macros that are local to a "body".
-;;; (They may be listed in this case, however.) We need this information
-;;; for top-level modules since a top-level module expands into a letrec
-;;; for non-top-level variables and top-level definitions (assignments) for
-;;; top-level variables. Because of the general nature of macro
-;;; transformers, we cannot determine the set of implicit exports from the
-;;; transformer code, so without the user's help, we'd have to put all
-;;; variables at top level.
-;;;
-;;; Each such top-level identifier is given a generated name (gensym).
-;;; When a top-level module is imported at top level, a compile-time
-;;; alias is established from the top-level name to the generated name.
-;;; The expander follows these aliases transparently. When any module is
-;;; imported anywhere other than at top level, the id-var-name of the
-;;; import identifier is set to the id-var-name of the export identifier.
-;;; Since we can't determine the actual labels for identifiers defined in
-;;; top-level modules until we determine which are placed in the letrec
-;;; and which make it to top level, we give each an "indirect" label---a
-;;; pair whose car will eventually contain the actual label. Import does
-;;; not follow the indirect, but id-var-name does.
-;;;
-;;; All identifiers defined within a local module are folded into the
-;;; letrec created for the enclosing body. Visibility is controlled in
-;;; this case and for nested top-level modules by introducing a new wrap
-;;; for each module.
-
-
-;;; Bootstrapping:
-
-;;; When changing syntax-object representations, it is necessary to support
-;;; both old and new syntax-object representations in id-var-name. It
-;;; should be sufficient to recognize old representations and treat
-;;; them as not lexically bound.
-
-
-(let ()
-
-(define-syntax when
- (syntax-rules ()
- ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
-(define-syntax unless
- (syntax-rules ()
- ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
-(define-syntax define-structure
- (lambda (x)
- (define construct-name
- (lambda (template-identifier . args)
- (datum->syntax-object
- template-identifier
- (string->symbol
- (apply string-append
- (map (lambda (x)
- (if (string? x)
- x
- (symbol->string (syntax-object->datum x))))
- args))))))
- (syntax-case x ()
- ((_ (name id1 ...))
- (andmap identifier? (syntax (name id1 ...)))
- (with-syntax
- ((constructor (construct-name (syntax name) "make-" (syntax name)))
- (predicate (construct-name (syntax name) (syntax name) "?"))
- ((access ...)
- (map (lambda (x) (construct-name x (syntax name) "-" x))
- (syntax (id1 ...))))
- ((assign ...)
- (map (lambda (x)
- (construct-name x "set-" (syntax name) "-" x "!"))
- (syntax (id1 ...))))
- (structure-length
- (+ (length (syntax (id1 ...))) 1))
- ((index ...)
- (let f ((i 1) (ids (syntax (id1 ...))))
- (if (null? ids)
- '()
- (cons i (f (+ i 1) (cdr ids)))))))
- (syntax (begin
- (define constructor
- (lambda (id1 ...)
- (vector 'name id1 ... )))
- (define predicate
- (lambda (x)
- (and (vector? x)
- (= (vector-length x) structure-length)
- (eq? (vector-ref x 0) 'name))))
- (define access
- (lambda (x)
- (vector-ref x index)))
- ...
- (define assign
- (lambda (x update)
- (vector-set! x index update)))
- ...)))))))
-
-(define noexpand "noexpand")
-
-;;; hooks to nonportable run-time helpers
-(begin
-(define-syntax fx+ (identifier-syntax +))
-(define-syntax fx- (identifier-syntax -))
-(define-syntax fx= (identifier-syntax =))
-(define-syntax fx< (identifier-syntax <))
-
-(define annotation? (lambda (x) #f))
-
-(define top-level-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x))))
-
-(define local-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x))))
-
-(define error-hook
- (lambda (who why what)
- (error who "~a ~s" why what)))
-
-(define-syntax gensym-hook
- (syntax-rules ()
- ((_) (gensym))))
-
-(define put-global-definition-hook
- (lambda (symbol val)
- ($sc-put-cte symbol val)))
-
-(define get-global-definition-hook
- (lambda (symbol)
- (getprop symbol '*sc-expander*)))
-
-(define get-import-binding
- (lambda (symbol token)
- (getprop symbol token)))
-
-(define generate-id
- (let ((b (- 127 32 2)))
- ; session-key should generate a unique integer for each system run
- ; to support separate compilation
- (define session-key (lambda () 0))
- (define make-digit (lambda (x) (integer->char (fx+ x 33))))
- (define fmt
- (lambda (n)
- (let fmt ((n n) (a '()))
- (if (< n b)
- (list->string (cons (make-digit n) a))
- (let ((r (modulo n b)) (rest (quotient n b)))
- (fmt rest (cons (make-digit r) a)))))))
- (let ((prefix (fmt (session-key))) (n -1))
- (lambda (name)
- (set! n (+ n 1))
- (let ((newsym (string->symbol (string-append "#" prefix (fmt n)))))
- newsym)))))
-)
-
-
-;;; output constructors
-(begin
-(define-syntax build-application
- (syntax-rules ()
- ((_ source fun-exp arg-exps)
- `(,fun-exp . ,arg-exps))))
-
-(define-syntax build-conditional
- (syntax-rules ()
- ((_ source test-exp then-exp else-exp)
- `(if ,test-exp ,then-exp ,else-exp))))
-
-(define-syntax build-lexical-reference
- (syntax-rules ()
- ((_ type source var)
- var)))
-
-(define-syntax build-lexical-assignment
- (syntax-rules ()
- ((_ source var exp)
- `(set! ,var ,exp))))
-
-(define-syntax build-global-reference
- (syntax-rules ()
- ((_ source var)
- var)))
-
-(define-syntax build-global-assignment
- (syntax-rules ()
- ((_ source var exp)
- `(set! ,var ,exp))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ source var exp)
- `(define ,var ,exp))))
-
-(define-syntax build-module-definition
- ; should have the effect of a global definition but may not appear at top level
- (identifier-syntax build-global-assignment))
-
-(define-syntax build-cte-install
- ; should build a call that has the same effect as calling the
- ; global definition hook
- (syntax-rules ()
- ((_ sym exp) `($sc-put-cte ',sym ,exp))))
-
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ src vars exp)
- `(lambda ,vars ,exp))))
-
-(define-syntax build-primref
- (syntax-rules ()
- ((_ src name) name)
- ((_ src level name) name)))
-
-(define-syntax build-data
- (syntax-rules ()
- ((_ src exp) `',exp)))
-
-(define build-sequence
- (lambda (src exps)
- (if (null? (cdr exps))
- (car exps)
- `(begin ,@exps))))
-
-(define build-letrec
- (lambda (src vars val-exps body-exp)
- (if (null? vars)
- body-exp
- `(letrec ,(map list vars val-exps) ,body-exp))))
-
-(define-syntax build-lexical-var
- (syntax-rules ()
- ((_ src id) (gensym))))
-
-(define-syntax self-evaluating?
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
-)
-
-(define-structure (syntax-object expression wrap))
-
-(define-syntax unannotate
- (syntax-rules ()
- ((_ x)
- (let ((e x))
- (if (annotation? e)
- (annotation-expression e)
- e)))))
-
-(define-syntax no-source (identifier-syntax #f))
-
-(define source-annotation
- (lambda (x)
- (cond
- ((annotation? x) (annotation-source x))
- ((syntax-object? x) (source-annotation (syntax-object-expression x)))
- (else no-source))))
-
-(define-syntax arg-check
- (syntax-rules ()
- ((_ pred? e who)
- (let ((x e))
- (if (not (pred? x)) (error-hook who "invalid argument" x))))))
-
-;;; compile-time environments
-
-;;; wrap and environment comprise two level mapping.
-;;; wrap : id --> label
-;;; env : label --> <element>
-
-;;; environments are represented in two parts: a lexical part and a global
-;;; part. The lexical part is a simple list of associations from labels
-;;; to bindings. The global part is implemented by
-;;; {put,get}-global-definition-hook and associates symbols with
-;;; bindings.
-
-;;; global (assumed global variable) and displaced-lexical (see below)
-;;; do not show up in any environment; instead, they are fabricated by
-;;; lookup when it finds no other bindings.
-
-;;; <environment> ::= ((<label> . <binding>)*)
-
-;;; identifier bindings include a type and a value
-
-;;; <binding> ::= (macro . <procedure>) macros
-;;; (deferred . <expanded code>) lazy-evaluation of transformers
-;;; (core . <procedure>) core forms
-;;; (begin) begin
-;;; (define) define
-;;; (define-syntax) define-syntax
-;;; (local-syntax . rec?) let-syntax/letrec-syntax
-;;; (eval-when) eval-when
-;;; (syntax . (<var> . <level>)) pattern variables
-;;; (global . <symbol>) assumed global variable
-;;; (lexical . <var>) lexical variables
-;;; (displaced-lexical . #f) id-var-name not found in store
-;;; <level> ::= <nonnegative integer>
-;;; <var> ::= variable returned by build-lexical-var
-
-;;; a macro is a user-defined syntactic-form. a core is a system-defined
-;;; syntactic form. begin, define, define-syntax, and eval-when are
-;;; treated specially since they are sensitive to whether the form is
-;;; at top-level and (except for eval-when) can denote valid internal
-;;; definitions.
-
-;;; a pattern variable is a variable introduced by syntax-case and can
-;;; be referenced only within a syntax form.
-
-;;; any identifier for which no top-level syntax definition or local
-;;; binding of any kind has been seen is assumed to be a global
-;;; variable.
-
-;;; a lexical variable is a lambda- or letrec-bound variable.
-
-;;; a displaced-lexical identifier is a lexical identifier removed from
-;;; it's scope by the return of a syntax object containing the identifier.
-;;; a displaced lexical can also appear when a letrec-syntax-bound
-;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
-;;; a displaced lexical should never occur with properly written macros.
-
-(define make-binding (lambda (x y) (cons x y)))
-(define binding-type car)
-(define binding-value cdr)
-(define set-binding-type! set-car!)
-(define set-binding-value! set-cdr!)
-(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
-
-(define-syntax null-env (identifier-syntax '()))
-
-(define extend-env
- (lambda (label binding r)
- (cons (cons label binding) r)))
-
-(define extend-env*
- (lambda (labels bindings r)
- (if (null? labels)
- r
- (extend-env* (cdr labels) (cdr bindings)
- (extend-env (car labels) (car bindings) r)))))
-
-(define extend-var-env*
- ; variant of extend-env* that forms "lexical" binding
- (lambda (labels vars r)
- (if (null? labels)
- r
- (extend-var-env* (cdr labels) (cdr vars)
- (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
-
-;;; we use a "macros only" environment in expansion of local macro
-;;; definitions so that their definitions can use local macros without
-;;; attempting to use other lexical identifiers.
-;;;
-;;; - can make this null-env if we don't want to allow macros to use other
-;;; macros in defining their transformers
-;;; - can add a cache here if it pays off
-(define transformer-env
- (lambda (r)
- (if (null? r)
- '()
- (let ((a (car r)))
- (if (eq? (cadr a) 'lexical) ; only strip out lexical so that (transformer x) works
- (transformer-env (cdr r))
- (cons a (transformer-env (cdr r))))))))
-
-(define displaced-lexical-error
- (lambda (id)
- (syntax-error id
- (if (id-var-name id empty-wrap)
- "identifier out of context"
- "identifier not visible"))))
-
-(define lookup*
- ; x may be a label or a symbol
- ; although symbols are usually global, we check the environment first
- ; anyway because a temporary binding may have been established by
- ; fluid-let-syntax
- (lambda (x r)
- (cond
- ((assq x r) => cdr)
- ((symbol? x)
- (or (get-global-definition-hook x) (make-binding 'global x)))
- (else (make-binding 'displaced-lexical #f)))))
-
-(define sanitize-binding
- (lambda (b)
- (cond
- ((procedure? b) (make-binding 'macro b))
- ((binding? b)
- (case (binding-type b)
- ((core macro macro!) (and (procedure? (binding-value b)) b))
- ((module) (and (interface? (binding-value b)) b))
- (else b)))
- (else #f))))
-
-(define lookup
- (lambda (x r)
- (define whack-binding!
- (lambda (b *b)
- (set-binding-type! b (binding-type *b))
- (set-binding-value! b (binding-value *b))))
- (let ((b (lookup* x r)))
- (case (binding-type b)
-; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
- ((deferred)
- (whack-binding! b
- (let ((*b (local-eval-hook (binding-value b))))
- (or (sanitize-binding *b)
- (syntax-error *b "invalid transformer"))))
- (case (binding-type b)
-; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
- (else b)))
- (else b)))))
-
-(define global-extend
- (lambda (type sym val)
- (put-global-definition-hook sym (make-binding type val))))
-
-
-;;; Conceptually, identifiers are always syntax objects. Internally,
-;;; however, the wrap is sometimes maintained separately (a source of
-;;; efficiency and confusion), so that symbols are also considered
-;;; identifiers by id?. Externally, they are always wrapped.
-
-(define nonsymbol-id?
- (lambda (x)
- (and (syntax-object? x)
- (symbol? (unannotate (syntax-object-expression x))))))
-
-(define id?
- (lambda (x)
- (cond
- ((symbol? x) #t)
- ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
- ((annotation? x) (symbol? (annotation-expression x)))
- (else #f))))
-
-(define-syntax id-sym-name
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
-
-(define id-sym-name&marks
- (lambda (x w)
- (if (syntax-object? x)
- (values
- (unannotate (syntax-object-expression x))
- (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
- (values (unannotate x) (wrap-marks w)))))
-
-;;; syntax object wraps
-
-;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
-;;; <subst> ::= <ribcage> | <shift>
-;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
-;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
-;;; <ex-symname> ::= <symname> | <import token> | <barrier>
-;;; <shift> ::= shift
-;;; <barrier> ::= #f ; inserted by import-only
-;;; <import token> ::= #<"import-token" <token>>
-;;; <token> ::= <generated id>
-
-(define make-wrap cons)
-(define wrap-marks car)
-(define wrap-subst cdr)
-
-(define-syntax subst-rename? (identifier-syntax vector?))
-(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
-(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
-(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
-(define-syntax make-rename
- (syntax-rules ()
- ((_ old new marks) (vector old new marks))))
-
-;;; labels
-
-;;; simple labels must be comparable with "eq?" and distinct from symbols
-;;; and pairs.
-
-;;; indirect labels, which are implemented as pairs, are used to support
-;;; import aliasing for identifiers exported (explictly or implicitly) from
-;;; top-level modules. chi-external creates an indirect label for each
-;;; defined identifier, import causes the pair to be shared aliases it
-;;; establishes, and chi-top-module whacks the pair to hold the top-level
-;;; identifier name (symbol) if the id is to be placed at top level, before
-;;; expanding the right-hand sides of the definitions in the module.
-
-(define gen-label
- (lambda () (string #\i)))
-(define label?
- (lambda (x)
- (or (string? x) ; normal lexical labels
- (symbol? x) ; global labels (symbolic names)
- (indirect-label? x))))
-
-(define gen-labels
- (lambda (ls)
- (if (null? ls)
- '()
- (cons (gen-label) (gen-labels (cdr ls))))))
-
-(define gen-indirect-label
- (lambda () (list (gen-label))))
-
-(define indirect-label? pair?)
-(define get-indirect-label car)
-(define set-indirect-label! set-car!)
-
-(define-structure (ribcage symnames marks labels))
-(define-syntax empty-wrap (identifier-syntax '(())))
-
-(define-syntax top-wrap (identifier-syntax '((top))))
-
-(define-syntax top-marked?
- (syntax-rules ()
- ((_ w) (memq 'top (wrap-marks w)))))
-
-(define-syntax only-top-marked?
- (syntax-rules ()
- ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
-
-;;; Marks must be comparable with "eq?" and distinct from pairs and
-;;; the symbol top. We do not use integers so that marks will remain
-;;; unique even across file compiles.
-
-(define-syntax the-anti-mark (identifier-syntax #f))
-
-(define anti-mark
- (lambda (w)
- (make-wrap (cons the-anti-mark (wrap-marks w))
- (cons 'shift (wrap-subst w)))))
-
-(define-syntax new-mark
- (syntax-rules ()
- ((_) (string #\m))))
-
-(define barrier-marker #f)
-(module (make-import-token import-token? import-token-key)
- (define tag 'import-token)
- (define make-import-token (lambda (x) (cons tag x)))
- (define import-token? (lambda (x) (and (pair? x) (eq? (car x) tag))))
- (define import-token-key cdr))
-
-;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
-;;; internal definitions, in which the ribcages are built incrementally
-(define-syntax make-empty-ribcage
- (syntax-rules ()
- ((_) (make-ribcage '() '() '()))))
-
-(define extend-ribcage!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
- (lambda (ribcage id label)
- (set-ribcage-symnames! ribcage
- (cons (unannotate (syntax-object-expression id))
- (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (wrap-marks (syntax-object-wrap id))
- (ribcage-marks ribcage)))
- (set-ribcage-labels! ribcage
- (cons label (ribcage-labels ribcage)))))
-
-(define extend-ribcage-barrier!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
- (lambda (ribcage killer-id)
- (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
-
-(define extend-ribcage-barrier-help!
- (lambda (ribcage wrap)
- (set-ribcage-symnames! ribcage
- (cons barrier-marker (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
-
-(define extend-ribcage-subst!
- ; ribcage guaranteed to be list-based
- (lambda (ribcage token)
- (set-ribcage-symnames! ribcage
- (cons (make-import-token token) (ribcage-symnames ribcage)))))
-
-(define lookup-import-binding-name
- (lambda (sym key marks)
- (let ((new (get-import-binding sym key)))
- (and new
- (let f ((new new))
- (cond
- ((pair? new) (or (f (car new)) (f (cdr new))))
- ((same-marks? marks (wrap-marks (syntax-object-wrap new))) new)
- (else #f)))))))
-
-;;; make-binding-wrap creates vector-based ribcages
-(define make-binding-wrap
- (lambda (ids labels w)
- (if (null? ids)
- w
- (make-wrap
- (wrap-marks w)
- (cons
- (let ((labelvec (list->vector labels)))
- (let ((n (vector-length labelvec)))
- (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
- (let f ((ids ids) (i 0))
- (if (not (null? ids))
- (call-with-values
- (lambda () (id-sym-name&marks (car ids) w))
- (lambda (symname marks)
- (vector-set! symnamevec i symname)
- (vector-set! marksvec i marks)
- (f (cdr ids) (fx+ i 1))))))
- (make-ribcage symnamevec marksvec labelvec))))
- (wrap-subst w))))))
-
-;;; make-trimmed-syntax-object is used by make-resolved-interface to support
-;;; creation of module export lists whose constituent ids do not contain
-;;; unnecessary substitutions or marks.
-(define make-trimmed-syntax-object
- (lambda (id)
- (call-with-values
- (lambda () (id-var-name&marks id empty-wrap))
- (lambda (tosym marks)
- (unless tosym
- (syntax-error id "identifier not visible for export"))
- (let ((fromsym (id-sym-name id)))
- (make-syntax-object fromsym
- (make-wrap marks
- (list (make-ribcage (vector fromsym) (vector marks) (vector tosym))))))))))
-
-;;; Scheme's append should not copy the first argument if the second is
-;;; nil, but it does, so we define a smart version here.
-(define smart-append
- (lambda (m1 m2)
- (if (null? m2)
- m1
- (append m1 m2))))
-
-(define join-wraps
- (lambda (w1 w2)
- (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
- (if (null? m1)
- (if (null? s1)
- w2
- (make-wrap
- (wrap-marks w2)
- (smart-append s1 (wrap-subst w2))))
- (make-wrap
- (smart-append m1 (wrap-marks w2))
- (smart-append s1 (wrap-subst w2)))))))
-
-(define join-marks
- (lambda (m1 m2)
- (smart-append m1 m2)))
-
-(define same-marks?
- (lambda (x y)
- (or (eq? x y)
- (and (not (null? x))
- (not (null? y))
- (eq? (car x) (car y))
- (same-marks? (cdr x) (cdr y))))))
-
-(define id-var-name-loc&marks
- (lambda (id w)
- (define search
- (lambda (sym subst marks)
- (if (null? subst)
- (values sym marks)
- (let ((fst (car subst)))
- (if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
- (let ((symnames (ribcage-symnames fst)))
- (if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
- (define search-list-rib
- (lambda (sym subst marks symnames ribcage)
- (let f ((symnames symnames) (i 0))
- (cond
- ((null? symnames) (search sym (cdr subst) marks))
- ((and (eq? (car symnames) sym)
- (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
- ((import-token? (car symnames))
- (cond
- ((lookup-import-binding-name sym (import-token-key (car symnames)) marks) =>
- (lambda (id)
- (if (symbol? id)
- (values id marks)
- (id-var-name&marks id empty-wrap)))) ; could be more efficient: new is a resolved id
- (else (f (cdr symnames) i))))
- ((and (eq? (car symnames) barrier-marker)
- (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values #f marks))
- (else (f (cdr symnames) (fx+ i 1)))))))
- (define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
- (let ((n (vector-length symnames)))
- (let f ((i 0))
- (cond
- ((fx= i n) (search sym (cdr subst) marks))
- ((and (eq? (vector-ref symnames i) sym)
- (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
- (else (f (fx+ i 1))))))))
- (cond
- ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
- ((syntax-object? id)
- (let ((sym (unannotate (syntax-object-expression id)))
- (w1 (syntax-object-wrap id)))
- (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
- (call-with-values (lambda () (search sym (wrap-subst w) marks))
- (lambda (new-id marks)
- (if (eq? new-id sym)
- (search sym (wrap-subst w1) marks)
- (values new-id marks)))))))
- ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
- (else (error-hook 'id-var-name "invalid id" id)))))
-
-(define id-var-name&marks
- ; this version follows indirect labels
- (lambda (id w)
- (call-with-values
- (lambda () (id-var-name-loc&marks id w))
- (lambda (label marks)
- (values (if (indirect-label? label) (get-indirect-label label) label) marks)))))
-
-(define id-var-name-loc
- ; this version doesn't follow indirect labels
- (lambda (id w)
- (call-with-values
- (lambda () (id-var-name-loc&marks id w))
- (lambda (label marks) label))))
-
-(define id-var-name
- ; this version follows indirect labels
- (lambda (id w)
- (call-with-values
- (lambda () (id-var-name-loc&marks id w))
- (lambda (label marks)
- (if (indirect-label? label) (get-indirect-label label) label)))))
-
-;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
-;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
-
-(define free-id=?
- (lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
-(define-syntax literal-id=? (identifier-syntax free-id=?))
-
-;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
-;;; long as the missing portion of the wrap is common to both of the ids
-;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
-
-(define bound-id=?
- (lambda (i j)
- (if (and (syntax-object? i) (syntax-object? j))
- (and (eq? (unannotate (syntax-object-expression i))
- (unannotate (syntax-object-expression j)))
- (same-marks? (wrap-marks (syntax-object-wrap i))
- (wrap-marks (syntax-object-wrap j))))
- (eq? (unannotate i) (unannotate j)))))
-
-;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
-;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
-;;; as long as the missing portion of the wrap is common to all of the
-;;; ids.
-
-(define valid-bound-ids?
- (lambda (ids)
- (and (let all-ids? ((ids ids))
- (or (null? ids)
- (and (id? (car ids))
- (all-ids? (cdr ids)))))
- (distinct-bound-ids? ids))))
-
-;;; distinct-bound-ids? expects a list of ids and returns #t if there are
-;;; no duplicates. It is quadratic on the length of the id list; long
-;;; lists could be sorted to make it more efficient. distinct-bound-ids?
-;;; may be passed unwrapped (or partially wrapped) ids as long as the
-;;; missing portion of the wrap is common to all of the ids.
-
-(define distinct-bound-ids?
- (lambda (ids)
- (let distinct? ((ids ids))
- (or (null? ids)
- (and (not (bound-id-member? (car ids) (cdr ids)))
- (distinct? (cdr ids)))))))
-
-(define invalid-ids-error
- ; find first bad one and complain about it
- (lambda (ids exp class)
- (let find ((ids ids) (gooduns '()))
- (if (null? ids)
- (syntax-error exp) ; shouldn't happen
- (if (id? (car ids))
- (if (bound-id-member? (car ids) gooduns)
- (syntax-error (car ids) "duplicate " class)
- (find (cdr ids) (cons (car ids) gooduns)))
- (syntax-error (car ids) "invalid " class))))))
-
-(define bound-id-member?
- (lambda (x list)
- (and (not (null? list))
- (or (bound-id=? x (car list))
- (bound-id-member? x (cdr list))))))
-
-;;; wrapping expressions and identifiers
-
-(define wrap
- (lambda (x w)
- (cond
- ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
- ((syntax-object? x)
- (make-syntax-object
- (syntax-object-expression x)
- (join-wraps w (syntax-object-wrap x))))
- ((null? x) x)
- (else (make-syntax-object x w)))))
-
-(define source-wrap
- (lambda (x w s)
- (wrap (if s (make-annotation x s #f) x) w)))
-
-;;; expanding
-
-(define chi-sequence
- (lambda (body r w s)
- (build-sequence s
- (let dobody ((body body) (r r) (w w))
- (if (null? body)
- '()
- (let ((first (chi (car body) r w)))
- (cons first (dobody (cdr body) r w))))))))
-
-(define chi-top-sequence
- (lambda (body r w s m esew ribcage)
- (build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew))
- (if (null? body)
- '()
- (let ((first (chi-top (car body) r w m esew ribcage)))
- (cons first (dobody (cdr body) r w m esew))))))))
-
-(define chi-when-list
- (lambda (e when-list w)
- ; when-list is syntax'd version of list of situations
- (let f ((when-list when-list) (situations '()))
- (if (null? when-list)
- situations
- (f (cdr when-list)
- (cons (let ((x (car when-list)))
- (cond
- ((literal-id=? x (syntax compile)) 'compile)
- ((literal-id=? x (syntax load)) 'load)
- ((literal-id=? x (syntax eval)) 'eval)
- (else (syntax-error (wrap x w)
- "invalid eval-when situation"))))
- situations))))))
-
-;;; syntax-type returns five values: type, value, e, w, and s. The first
-;;; two are described in the table below.
-;;;
-;;; type value explanation
-;;; -------------------------------------------------------------------
-;;; begin none begin keyword
-;;; begin-form none begin expression
-;;; call none any other call
-;;; constant none self-evaluating datum
-;;; core procedure core form (including singleton)
-;;; define none define keyword
-;;; define-form none variable definition
-;;; define-syntax none define-syntax keyword
-;;; define-syntax-form none syntax definition
-;;; displaced-lexical none displaced lexical identifier
-;;; eval-when none eval-when keyword
-;;; eval-when-form none eval-when form
-;;; global name global variable reference
-;;; import none import keyword
-;;; import-form none import form
-;;; lexical name lexical variable reference
-;;; lexical-call name call to lexical variable
-;;; local-syntax rec? letrec-syntax/let-syntax keyword
-;;; local-syntax-form rec? syntax definition
-;;; module none module keyword
-;;; module-form none module definition
-;;; other none anything else
-;;; syntax level pattern variable
-;;;
-;;; For all forms, e is the form, w is the wrap for e. and s is the source.
-;;;
-;;; syntax-type expands macros and unwraps as necessary to get to
-;;; one of the forms above.
-
-(define syntax-type
- (lambda (e r w s rib)
- (cond
- ((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r))
- (type (binding-type b)))
- (case type
- ((lexical) (values type (binding-value b) e w s))
- ((global) (values type (binding-value b) e w s))
- ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w s rib) r empty-wrap #f rib))
- (else (values type (binding-value b) e w s)))))
- ((pair? e)
- (let ((first (car e)))
- (if (id? first)
- (let* ((n (id-var-name first w))
- (b (lookup n r))
- (type (binding-type b)))
- (case type
- ((lexical) (values 'lexical-call (binding-value b) e w s))
- ((macro macro!)
- (syntax-type (chi-macro (binding-value b) e r w s rib)
- r empty-wrap #f rib))
- ((core) (values type (binding-value b) e w s))
- ((local-syntax)
- (values 'local-syntax-form (binding-value b) e w s))
- ((begin) (values 'begin-form #f e w s))
- ((eval-when) (values 'eval-when-form #f e w s))
- ((define) (values 'define-form #f e w s))
- ((define-syntax) (values 'define-syntax-form #f e w s))
- ((module-key) (values 'module-form #f e w s))
- ((import) (values 'import-form (and (binding-value b) (wrap first w)) e w s))
- ((set!) (chi-set! e r w s rib))
- (else (values 'call #f e w s))))
- (values 'call #f e w s))))
- ((syntax-object? e)
- ;; s can't be valid source if we've unwrapped
- (syntax-type (syntax-object-expression e)
- r
- (join-wraps w (syntax-object-wrap e))
- no-source rib))
- ((annotation? e)
- (syntax-type (annotation-expression e) r w (annotation-source e) rib))
- ((self-evaluating? e) (values 'constant #f e w s))
- (else (values 'other #f e w s)))))
-
-(define chi-top-expr
- (lambda (e r w top-ribcage)
- (call-with-values
- (lambda () (syntax-type e r w no-source top-ribcage))
- (lambda (type value e w s)
- (chi-expr type value e r w s)))))
-
-(define chi-top
- (lambda (e r w m esew top-ribcage)
- (define-syntax eval-if-c&e
- (syntax-rules ()
- ((_ m e)
- (let ((x e))
- (if (eq? m 'c&e) (top-level-eval-hook x))
- x))))
- (call-with-values
- (lambda () (syntax-type e r w no-source top-ribcage))
- (lambda (type value e w s)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) (chi-void))
- ((_ e1 e2 ...)
- (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew top-ribcage))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s
- (lambda (body r w s)
- (chi-top-sequence body r w s m esew top-ribcage))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e (syntax (x ...)) w))
- (body (syntax (e1 e2 ...))))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (chi-top-sequence body r w s 'e '(eval) top-ribcage)
- (chi-void)))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (chi-top-sequence body r w s 'c&e '(compile load) top-ribcage)
- (if (memq m '(c c&e))
- (chi-top-sequence body r w s 'c '(load) top-ribcage)
- (chi-void))))
- ((or (memq 'compile when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (chi-top-sequence body r w s 'e '(eval) top-ribcage))
- (chi-void))
- (else (chi-void)))))))
- ((define-syntax-form)
- (parse-define-syntax e w s
- (lambda (id rhs w)
- (let ((id (wrap id w)))
- (let ((n (id-var-name id empty-wrap)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((displaced-lexical) (displaced-lexical-error id)))))
- (ct-eval/residualize m esew
- (lambda ()
- (build-cte-install
- (let ((sym (id-sym-name id)))
- (if (only-top-marked? id)
- sym
- (let ((marks (wrap-marks (syntax-object-wrap id))))
- (make-syntax-object sym
- (make-wrap marks
- (list (make-ribcage (vector sym)
- (vector marks) (vector (generate-id sym)))))))))
- (chi rhs (transformer-env r) w))))))))
- ((define-form)
- (parse-define e w s
- (lambda (id rhs w)
- (let ((id (wrap id w)))
- (let ((n (id-var-name id empty-wrap)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((displaced-lexical) (displaced-lexical-error id)))))
- (let ((sym (id-sym-name id)))
- (let ((valsym (if (only-top-marked? id) sym (generate-id sym))))
- (build-sequence no-source
- (list
- (ct-eval/residualize m esew
- (lambda ()
- (build-cte-install
- (if (eq? sym valsym)
- sym
- (let ((marks (wrap-marks (syntax-object-wrap id))))
- (make-syntax-object sym
- (make-wrap marks
- (list (make-ribcage (vector sym)
- (vector marks) (vector valsym)))))))
- (build-data no-source (make-binding 'global valsym)))))
- (eval-if-c&e m (build-global-definition s valsym (chi rhs r w))))))
- )))))
- ((module-form)
- (let ((r (cons '("top-level module placeholder" . (placeholder)) r))
- (ribcage (make-empty-ribcage)))
- (parse-module e w s (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))
- (lambda (id exports forms)
- (if id
- (begin
- (let ((n (id-var-name id empty-wrap)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((displaced-lexical) (displaced-lexical-error (wrap id w))))))
- (chi-top-module e r ribcage w s m esew id exports forms))
- (chi-top-module e r ribcage w s m esew #f exports forms))))))
- ((import-form)
- (parse-import e w s
- (lambda (mid)
- (ct-eval/residualize m esew
- (lambda ()
- (when value (syntax-error (source-wrap e w s) "not valid at top-level"))
- (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
- (case (binding-type binding)
- ((module) (do-top-import mid (interface-token (binding-value binding))))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "import from unknown module")))))))))
- (else (eval-if-c&e m (chi-expr type value e r w s))))))))
-
-(define flatten-exports
- (lambda (exports)
- (let loop ((exports exports) (ls '()))
- (if (null? exports)
- ls
- (loop (cdr exports)
- (if (pair? (car exports))
- (loop (car exports) ls)
- (cons (car exports) ls)))))))
-
-
-(define-structure (interface exports token))
-
-(define make-trimmed-interface
- ; trim out implicit exports
- (lambda (exports)
- (make-interface
- (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
- #f)))
-
-(define make-resolved-interface
- ; trim out implicit exports & resolve others to actual top-level symbol
- (lambda (exports import-token)
- (make-interface
- (list->vector (map (lambda (x) (make-trimmed-syntax-object (if (pair? x) (car x) x))) exports))
- import-token)))
-
-(define-structure (module-binding type id label imps val))
-
-(define chi-top-module
- (lambda (e r ribcage w s m esew id exports forms)
- (let ((fexports (flatten-exports exports)))
- (chi-external ribcage (source-wrap e w s)
- (map (lambda (d) (cons r d)) forms) r exports fexports m esew
- (lambda (bindings inits)
- ; dvs & des: "defined" (letrec-bound) vars & rhs expressions
- ; svs & ses: "set!" (top-level) vars & rhs expressions
- (let partition ((fexports fexports) (bs bindings) (svs '()) (ses '()) (ctdefs '()))
- (if (null? fexports)
- ; remaining bindings are either local vars or local macros/modules
- (let partition ((bs bs) (dvs '()) (des '()))
- (if (null? bs)
- (let ((ses (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) ses))
- (des (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) des))
- (inits (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) inits)))
- ; we wait to do this here so that expansion of des & ses use
- ; local versions, which in particular, allows us to use macros
- ; locally even if esew tells us not to eval them
- (for-each (lambda (x)
- (apply (lambda (t label sym val)
- (when label (set-indirect-label! label sym)))
- x))
- ctdefs)
- (build-sequence no-source
- (list (ct-eval/residualize m esew
- (lambda ()
- (if (null? ctdefs)
- (chi-void)
- (build-sequence no-source
- (map (lambda (x)
- (apply (lambda (t label sym val)
- (build-cte-install sym
- (if (eq? t 'define-syntax-form)
- val
- (build-data no-source
- (make-binding 'module
- (make-resolved-interface val sym))))))
- x))
- ctdefs)))))
- (ct-eval/residualize m esew
- (lambda ()
- (let ((n (if id (id-sym-name id) #f)))
- (let* ((token (generate-id n))
- (b (build-data no-source
- (make-binding 'module
- (make-resolved-interface exports token)))))
- (if n
- (build-cte-install
- (if (only-top-marked? id)
- n
- (let ((marks (wrap-marks (syntax-object-wrap id))))
- (make-syntax-object n
- (make-wrap marks
- (list (make-ribcage (vector n)
- (vector marks) (vector (generate-id n))))))))
- b)
- (let ((n (generate-id 'tmp)))
- (build-sequence no-source
- (list (build-cte-install n b)
- (do-top-import n token)))))))))
- ; Some systems complain when undefined variables are assigned.
- (build-sequence no-source
- (map (lambda (v) (build-global-definition no-source v (chi-void))) svs))
- (build-letrec no-source
- dvs
- des
- (build-sequence no-source
- (list
- (if (null? svs)
- (chi-void)
- (build-sequence no-source
- (map (lambda (v e)
- (build-module-definition no-source v e))
- svs
- ses)))
- (if (null? inits)
- (chi-void)
- (build-sequence no-source inits)))))
- (chi-void))))
- (let ((b (car bs)))
- (case (module-binding-type b)
- ((define-form)
- (let ((var (gen-var (module-binding-id b))))
- (extend-store! r
- (get-indirect-label (module-binding-label b))
- (make-binding 'lexical var))
- (partition (cdr bs) (cons var dvs)
- (cons (module-binding-val b) des))))
- ((define-syntax-form module-form) (partition (cdr bs) dvs des))
- (else (error 'sc-expand-internal "unexpected module binding type"))))))
- (let ((id (car fexports)) (fexports (cdr fexports)))
- (define pluck-binding
- (lambda (id bs succ fail)
- (let loop ((bs bs) (new-bs '()))
- (if (null? bs)
- (fail)
- (if (bound-id=? (module-binding-id (car bs)) id)
- (succ (car bs) (smart-append (reverse new-bs) (cdr bs)))
- (loop (cdr bs) (cons (car bs) new-bs)))))))
- (pluck-binding id bs
- (lambda (b bs)
- (let ((t (module-binding-type b))
- (label (module-binding-label b))
- (imps (module-binding-imps b)))
- (let ((fexports (append imps fexports))
- (sym (generate-id (id-sym-name id))))
- (case t
- ((define-form)
- (set-indirect-label! label sym)
- (partition fexports bs (cons sym svs)
- (cons (module-binding-val b) ses)
- ctdefs))
- ((define-syntax-form)
- (partition fexports bs svs ses
- (cons (list t label sym (module-binding-val b)) ctdefs)))
- ((module-form)
- (let ((exports (module-binding-val b)))
- (partition (append (flatten-exports exports) fexports) bs
- svs ses
- (cons (list t label sym exports) ctdefs))))
- (else (error 'sc-expand-internal "unexpected module binding type"))))))
- (lambda () (partition fexports bs svs ses ctdefs)))))))))))
-
-(define id-set-diff
- (lambda (exports defs)
- (cond
- ((null? exports) '())
- ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
- (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
-
-(define extend-store!
- (lambda (r label binding)
- (set-cdr! r (extend-env label binding (cdr r)))))
-
-(define check-module-exports
- ; After processing the definitions of a module this is called to verify that the
- ; module has defined or imported each exported identifier. Because ids in fexports are
- ; wrapped with the given ribcage, they will contain substitutions for anything defined
- ; or imported here. These subsitutions can be used by do-import! and do-import-top! to
- ; provide access to reexported bindings, for example.
- (lambda (source-exp fexports ids)
- (define defined?
- (lambda (e ids)
- (ormap (lambda (x)
- (if (interface? x)
- (let ((token (interface-token x)))
- (if token
- (lookup-import-binding-name (id-sym-name e) token (wrap-marks (syntax-object-wrap e)))
- (let ((v (interface-exports x)))
- (let lp ((i (fx- (vector-length v) 1)))
- (and (fx>= i 0)
- (or (bound-id=? e (vector-ref v i))
- (lp (fx- i 1))))))))
- (bound-id=? e x)))
- ids)))
- (let loop ((fexports fexports) (missing '()))
- (if (null? fexports)
- (unless (null? missing) (syntax-error missing "missing definition for export(s)"))
- (let ((e (car fexports)) (fexports (cdr fexports)))
- (if (defined? e ids)
- (loop fexports missing)
- (loop fexports (cons e missing))))))))
-
-(define check-defined-ids
- (lambda (source-exp ls)
- (define b-i=?
- ; cope with fat-fingered top-level
- (lambda (x y)
- (if (symbol? x)
- (if (symbol? y)
- (eq? x y)
- (and (eq? x (id-sym-name y))
- (same-marks? (wrap-marks (syntax-object-wrap y)) (wrap-marks top-wrap))))
- (if (symbol? y)
- (and (eq? y (id-sym-name x))
- (same-marks? (wrap-marks (syntax-object-wrap x)) (wrap-marks top-wrap)))
- (bound-id=? x y)))))
- (define vfold
- (lambda (v p cls)
- (let ((len (vector-length v)))
- (let lp ((i 0) (cls cls))
- (if (fx= i len)
- cls
- (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
- (define conflicts
- (lambda (x y cls)
- (if (interface? x)
- (if (interface? y)
- (call-with-values
- (lambda ()
- (let ((xe (interface-exports x)) (ye (interface-exports y)))
- (if (fx> (vector-length xe) (vector-length ye))
- (values x ye)
- (values y xe))))
- (lambda (iface exports)
- (vfold exports (lambda (id cls) (id-iface-conflicts id iface cls)) cls)))
- (id-iface-conflicts y x cls))
- (if (interface? y)
- (id-iface-conflicts x y cls)
- (if (b-i=? x y) (cons x cls) cls)))))
- (define id-iface-conflicts
- (lambda (id iface cls)
- (let ((token (interface-token iface)))
- (if token
- (if (lookup-import-binding-name (id-sym-name id) token
- (if (symbol? id)
- (wrap-marks top-wrap)
- (wrap-marks (syntax-object-wrap id))))
- (cons id cls)
- cls)
- (vfold (interface-exports iface)
- (lambda (*id cls) (if (b-i=? *id id) (cons *id cls) cls))
- cls)))))
- (unless (null? ls)
- (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
- (if (null? ls)
- (unless (null? cls)
- (let ((cls (syntax-object->datum cls)))
- (syntax-error source-exp "duplicate definition for "
- (symbol->string (car cls))
- " in")))
- (let lp2 ((ls2 ls) (cls cls))
- (if (null? ls2)
- (lp (car ls) (cdr ls) cls)
- (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
-
-(define chi-external
- (lambda (ribcage source-exp body r exports fexports m esew k)
- (define return
- (lambda (bindings ids inits)
- (check-defined-ids source-exp ids)
- (check-module-exports source-exp fexports ids)
- (k bindings inits)))
- (define get-implicit-exports
- (lambda (id)
- (let f ((exports exports))
- (if (null? exports)
- '()
- (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
- (flatten-exports (cdar exports))
- (f (cdr exports)))))))
- (define update-imp-exports
- (lambda (bindings exports)
- (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
- (map (lambda (b)
- (let ((id (module-binding-id b)))
- (if (not (bound-id-member? id exports))
- b
- (make-module-binding
- (module-binding-type b)
- id
- (module-binding-label b)
- (append (get-implicit-exports id) (module-binding-imps b))
- (module-binding-val b)))))
- bindings))))
- (let parse ((body body) (ids '()) (bindings '()) (inits '()))
- (if (null? body)
- (return bindings ids inits)
- (let ((e (cdar body)) (er (caar body)))
- (call-with-values
- (lambda () (syntax-type e er empty-wrap no-source ribcage))
- (lambda (type value e w s)
- (case type
- ((define-form)
- (parse-define e w s
- (lambda (id rhs w)
- (let* ((id (wrap id w))
- (label (gen-indirect-label))
- (imps (get-implicit-exports id)))
- (extend-ribcage! ribcage id label)
- (parse
- (cdr body)
- (cons id ids)
- (cons (make-module-binding type id label
- imps (cons er (wrap rhs w)))
- bindings)
- inits)))))
- ((define-syntax-form)
- (parse-define-syntax e w s
- (lambda (id rhs w)
- (let* ((id (wrap id w))
- (label (gen-indirect-label))
- (imps (get-implicit-exports id))
- (exp (chi rhs (transformer-env er) w)))
- ; arrange to evaluate the transformer lazily
- (extend-store! r (get-indirect-label label) (cons 'deferred exp))
- (extend-ribcage! ribcage id label)
- (parse
- (cdr body)
- (cons id ids)
- (cons (make-module-binding type id label imps exp)
- bindings)
- inits)))))
- ((module-form)
- (let* ((*ribcage (make-empty-ribcage))
- (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
- (parse-module e w s *w
- (lambda (id *exports forms)
- (chi-external *ribcage (source-wrap e w s)
- (map (lambda (d) (cons er d)) forms)
- r *exports (flatten-exports *exports) m esew
- (lambda (*bindings *inits)
- (let* ((iface (make-trimmed-interface *exports))
- (bindings (append (if id *bindings (update-imp-exports *bindings *exports)) bindings))
- (inits (append inits *inits)))
- (if id
- (let ((label (gen-indirect-label))
- (imps (get-implicit-exports id)))
- (extend-store! r (get-indirect-label label)
- (make-binding 'module iface))
- (extend-ribcage! ribcage id label)
- (parse
- (cdr body)
- (cons id ids)
- (cons (make-module-binding type id label imps *exports) bindings)
- inits))
- (let ()
- (do-import! iface ribcage)
- (parse (cdr body) (cons iface ids) bindings inits))))))))))
- ((import-form)
- (parse-import e w s
- (lambda (mid)
- (let ((mlabel (id-var-name mid empty-wrap)))
- (let ((binding (lookup mlabel r)))
- (case (binding-type binding)
- ((module)
- (let ((iface (binding-value binding)))
- (when value (extend-ribcage-barrier! ribcage value))
- (do-import! iface ribcage)
- (parse
- (cdr body)
- (cons iface ids)
- (update-imp-exports bindings (vector->list (interface-exports iface)))
- inits)))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "import from unknown module"))))))))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 ...)
- (parse (let f ((forms (syntax (e1 ...))))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w))
- (f (cdr forms)))))
- ids bindings inits))))
- ((local-syntax-form)
- (chi-local-syntax value e er w s
- (lambda (forms er w s)
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w))
- (f (cdr forms)))))
- ids bindings inits))))
- (else ; found an init expression
- (return bindings ids
- (append inits (cons (cons er (source-wrap e w s)) (cdr body)))))))))))))
-
-(define vmap
- (lambda (fn v)
- (do ((i (fx- (vector-length v) 1) (fx- i 1))
- (ls '() (cons (fn (vector-ref v i)) ls)))
- ((fx< i 0) ls))))
-
-(define vfor-each
- (lambda (fn v)
- (let ((len (vector-length v)))
- (do ((i 0 (fx+ i 1)))
- ((fx= i len))
- (fn (vector-ref v i))))))
-
-(define do-top-import
- (lambda (mid token)
- (build-cte-install mid
- (build-data no-source
- (make-binding 'do-import token)))))
-
-(define ct-eval/residualize
- (lambda (m esew thunk)
- (case m
- ((c) (if (memq 'compile esew)
- (let ((e (thunk)))
- (top-level-eval-hook e)
- (if (memq 'load esew) e (chi-void)))
- (if (memq 'load esew) (thunk) (chi-void))))
- ((c&e) (let ((e (thunk))) (top-level-eval-hook e) e))
- (else (if (memq 'eval esew) (top-level-eval-hook (thunk))) (chi-void)))))
-
-(define chi
- (lambda (e r w)
- (call-with-values
- (lambda () (syntax-type e r w no-source #f))
- (lambda (type value e w s)
- (chi-expr type value e r w s)))))
-
-(define chi-expr
- (lambda (type value e r w s)
- (case type
- ((lexical)
- (build-lexical-reference 'value s value))
- ((core) (value e r w s))
- ((lexical-call)
- (chi-application
- (build-lexical-reference 'fun (source-annotation (car e)) value)
- e r w s))
- ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
- ((global) (build-global-reference s value))
- ((call) (chi-application (chi (car e) r w) e r w s))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s chi-sequence))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e (syntax (x ...)) w)))
- (if (memq 'eval when-list)
- (chi-sequence (syntax (e1 e2 ...)) r w s)
- (chi-void))))))
- ((define-form define-syntax-form module-form import-form)
- (syntax-error (source-wrap e w s) "invalid context for definition"))
- ((syntax)
- (syntax-error (source-wrap e w s)
- "reference to pattern variable outside syntax form"))
- ((displaced-lexical) (displaced-lexical-error (source-wrap e w s)))
- (else (syntax-error (source-wrap e w s))))))
-
-(define chi-application
- (lambda (x e r w s)
- (syntax-case e ()
- ((e0 e1 ...)
- (build-application s x
- (map (lambda (e) (chi e r w)) (syntax (e1 ...)))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define chi-set!
- (lambda (e r w s rib)
- (syntax-case e ()
- ((_ id val)
- (id? (syntax id))
- (let ((n (id-var-name (syntax id) w)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((macro!)
- (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
- (syntax-type (chi-macro (binding-value b)
- `(,(syntax set!) ,id ,val)
- r empty-wrap s rib) r empty-wrap s rib)))
- (else
- (values 'core
- (lambda (e r w s)
- ; repeat lookup in case we were first expression (init) in
- ; module or lambda body. we repeat id-var-name as well,
- ; although this is only necessary if we allow inits to
- ; preced definitions
- (let ((val (chi (syntax val) r w))
- (n (id-var-name (syntax id) w)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((lexical) (build-lexical-assignment s (binding-value b) val))
- ((global) (build-global-assignment s (binding-value b) val))
- ((displaced-lexical)
- (syntax-error (wrap (syntax id) w) "identifier out of context"))
- (else (syntax-error (source-wrap e w s)))))))
- e w s))))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define chi-macro
- (lambda (p e r w s rib)
- (define rebuild-macro-output
- (lambda (x m)
- (cond ((pair? x)
- (cons (rebuild-macro-output (car x) m)
- (rebuild-macro-output (cdr x) m)))
- ((syntax-object? x)
- (let ((w (syntax-object-wrap x)))
- (let ((ms (wrap-marks w)) (s (wrap-subst w)))
- (make-syntax-object (syntax-object-expression x)
- (if (and (pair? ms) (eq? (car ms) the-anti-mark))
- (make-wrap (cdr ms)
- (if rib (cons rib (cdr s)) (cdr s)))
- (make-wrap (cons m ms)
- (if rib
- (cons rib (cons 'shift s))
- (cons 'shift s))))))))
- ((vector? x)
- (let* ((n (vector-length x)) (v (make-vector n)))
- (do ((i 0 (fx+ i 1)))
- ((fx= i n) v)
- (vector-set! v i
- (rebuild-macro-output (vector-ref x i) m)))))
- ((symbol? x)
- (syntax-error (source-wrap e w s)
- "encountered raw symbol "
- (format "~s" x)
- " in output of macro"))
- (else x))))
- (rebuild-macro-output
- (let ((out (p (source-wrap e (anti-mark w) s))))
- (if (procedure? out)
- (out (lambda (id)
- (unless (identifier? id)
- (syntax-error id
- "environment argument is not an identifier"))
- (lookup (id-var-name id empty-wrap) r)))
- out))
- (new-mark))))
-
-(define chi-body
- ;; Here we create the empty wrap and new environment with placeholder
- ;; as required by chi-internal. On return we extend the environment
- ;; to recognize the var-labels as lexical variables and build a letrec
- ;; binding them to the var-vals which we expand here.
- (lambda (body outer-form r w)
- (let* ((r (cons '("placeholder" . (placeholder)) r))
- (ribcage (make-empty-ribcage))
- (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
- (body (map (lambda (x) (cons r (wrap x w))) body)))
- (chi-internal ribcage outer-form body r
- (lambda (exprs ids vars vals inits)
- (when (null? exprs) (syntax-error outer-form "no expressions in body"))
- (build-letrec no-source
- vars
- (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) vals)
- (build-sequence no-source
- (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) (append inits exprs)))))))))
-
-(define chi-internal
- ;; In processing the forms of the body, we create a new, empty wrap.
- ;; This wrap is augmented (destructively) each time we discover that
- ;; the next form is a definition. This is done:
- ;;
- ;; (1) to allow the first nondefinition form to be a call to
- ;; one of the defined ids even if the id previously denoted a
- ;; definition keyword or keyword for a macro expanding into a
- ;; definition;
- ;; (2) to prevent subsequent definition forms (but unfortunately
- ;; not earlier ones) and the first nondefinition form from
- ;; confusing one of the bound identifiers for an auxiliary
- ;; keyword; and
- ;; (3) so that we do not need to restart the expansion of the
- ;; first nondefinition form, which is problematic anyway
- ;; since it might be the first element of a begin that we
- ;; have just spliced into the body (meaning if we restarted,
- ;; we'd really need to restart with the begin or the macro
- ;; call that expanded into the begin, and we'd have to give
- ;; up allowing (begin <defn>+ <expr>+), which is itself
- ;; problematic since we don't know if a begin contains only
- ;; definitions until we've expanded it).
- ;;
- ;; Before processing the body, we also create a new environment
- ;; containing a placeholder for the bindings we will add later and
- ;; associate this environment with each form. In processing a
- ;; let-syntax or letrec-syntax, the associated environment may be
- ;; augmented with local keyword bindings, so the environment may
- ;; be different for different forms in the body. Once we have
- ;; gathered up all of the definitions, we evaluate the transformer
- ;; expressions and splice into r at the placeholder the new variable
- ;; and keyword bindings. This allows let-syntax or letrec-syntax
- ;; forms local to a portion or all of the body to shadow the
- ;; definition bindings.
- ;;
- ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
- ;; into the body.
- ;;
- ;; outer-form is fully wrapped w/source
- (lambda (ribcage source-exp body r k)
- (define return
- (lambda (exprs ids vars vals inits)
- (check-defined-ids source-exp ids)
- (k exprs ids vars vals inits)))
- (let parse ((body body) (ids '()) (vars '()) (vals '()) (inits '()))
- (if (null? body)
- (return body ids vars vals inits)
- (let ((e (cdar body)) (er (caar body)))
- (call-with-values
- (lambda () (syntax-type e er empty-wrap no-source ribcage))
- (lambda (type value e w s)
- (case type
- ((define-form)
- (parse-define e w s
- (lambda (id rhs w)
- (let ((id (wrap id w)) (label (gen-label)))
- (let ((var (gen-var id)))
- (extend-ribcage! ribcage id label)
- (extend-store! r label (make-binding 'lexical var))
- (parse
- (cdr body)
- (cons id ids)
- (cons var vars)
- (cons (cons er (wrap rhs w)) vals)
- inits))))))
- ((define-syntax-form)
- (parse-define-syntax e w s
- (lambda (id rhs w)
- (let ((id (wrap id w))
- (label (gen-label))
- (exp (chi rhs (transformer-env er) w)))
- (extend-ribcage! ribcage id label)
- (extend-store! r label (make-binding 'deferred exp))
- (parse (cdr body) (cons id ids) vars vals inits)))))
- ((module-form)
- (let* ((*ribcage (make-empty-ribcage))
- (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
- (parse-module e w s *w
- (lambda (id exports forms)
- (chi-internal *ribcage (source-wrap e w s)
- (map (lambda (d) (cons er d)) forms) r
- (lambda (*body *ids *vars *vals *inits)
- ; valid bound ids checked already by chi-internal
- (check-module-exports source-exp (flatten-exports exports) *ids)
- (let ((iface (make-trimmed-interface exports))
- (vars (append *vars vars))
- (vals (append *vals vals))
- (inits (append inits *inits *body)))
- (if id
- (let ((label (gen-label)))
- (extend-ribcage! ribcage id label)
- (extend-store! r label (make-binding 'module iface))
- (parse (cdr body) (cons id ids) vars vals inits))
- (let ()
- (do-import! iface ribcage)
- (parse (cdr body) (cons iface ids) vars vals inits))))))))))
- ((import-form)
- (parse-import e w s
- (lambda (mid)
- (let ((mlabel (id-var-name mid empty-wrap)))
- (let ((binding (lookup mlabel r)))
- (case (car binding)
- ((module)
- (let ((iface (cdr binding)))
- (when value (extend-ribcage-barrier! ribcage value))
- (do-import! iface ribcage)
- (parse (cdr body) (cons iface ids) vars vals inits)))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "import from unknown module"))))))))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 ...)
- (parse (let f ((forms (syntax (e1 ...))))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w))
- (f (cdr forms)))))
- ids vars vals inits))))
- ((local-syntax-form)
- (chi-local-syntax value e er w s
- (lambda (forms er w s)
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w))
- (f (cdr forms)))))
- ids vars vals inits))))
- (else ; found a non-definition
- (return (cons (cons er (source-wrap e w s)) (cdr body))
- ids vars vals inits))))))))))
-
-(define do-import!
- (lambda (interface ribcage)
- (let ((token (interface-token interface)))
- (if token
- (extend-ribcage-subst! ribcage token)
- (vfor-each
- (lambda (id)
- (let ((label1 (id-var-name-loc id empty-wrap)))
- (unless label1
- (syntax-error id "exported identifier not visible"))
- (extend-ribcage! ribcage id label1)))
- (interface-exports interface))))))
-
-(define parse-module
- (lambda (e w s *w k)
- (define listify
- (lambda (exports)
- (if (null? exports)
- '()
- (cons (syntax-case (car exports) ()
- ((ex ...) (listify (syntax (ex ...))))
- (x (if (id? (syntax x))
- (wrap (syntax x) *w)
- (syntax-error (source-wrap e w s)
- "invalid exports list in"))))
- (listify (cdr exports))))))
- (define return
- (lambda (id exports forms)
- (k id (listify exports) (map (lambda (x) (wrap x *w)) forms))))
- (syntax-case e ()
- ((_ (ex ...) form ...)
- (return #f (syntax (ex ...)) (syntax (form ...))))
- ((_ mid (ex ...) form ...)
- (id? (syntax mid))
- ; id receives old wrap so it won't be confused with id of same name
- ; defined within the module
- (return (wrap (syntax mid) w) (syntax (ex ...)) (syntax (form ...))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define parse-import
- (lambda (e w s k)
- (syntax-case e ()
- ((_ mid)
- (id? (syntax mid))
- (k (wrap (syntax mid) w)))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define parse-define
- (lambda (e w s k)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (k (syntax name) (syntax val) w))
- ((_ (name . args) e1 e2 ...)
- (and (id? (syntax name))
- (valid-bound-ids? (lambda-var-list (syntax args))))
- (k (wrap (syntax name) w)
- (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
- empty-wrap))
- ((_ name)
- (id? (syntax name))
- (k (wrap (syntax name) w) (syntax (void)) empty-wrap))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define parse-define-syntax
- (lambda (e w s k)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (k (syntax name) (syntax val) w))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define chi-lambda-clause
- (lambda (e c r w k)
- (syntax-case c ()
- (((id ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-error e "invalid parameter list in")
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (k new-vars
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env* labels new-vars r)
- (make-binding-wrap ids labels w)))))))
- ((ids e1 e2 ...)
- (let ((old-ids (lambda-var-list (syntax ids))))
- (if (not (valid-bound-ids? old-ids))
- (syntax-error e "invalid parameter list in")
- (let ((labels (gen-labels old-ids))
- (new-vars (map gen-var old-ids)))
- (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
- (if (null? ls1)
- ls2
- (f (cdr ls1) (cons (car ls1) ls2))))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env* labels new-vars r)
- (make-binding-wrap old-ids labels w)))))))
- (_ (syntax-error e)))))
-
-(define chi-local-syntax
- (lambda (rec? e r w s k)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
- (source-wrap e w s)
- "keyword")
- (let ((labels (gen-labels ids)))
- (let ((new-w (make-binding-wrap ids labels w)))
- (k (syntax (e1 e2 ...))
- (extend-env*
- labels
- (let ((w (if rec? new-w w))
- (trans-r (transformer-env r)))
- (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
- r)
- new-w
- s))))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define chi-void
- (lambda ()
- (build-application no-source (build-primref no-source 'void) '())))
-
-(define ellipsis?
- (lambda (x)
- (and (nonsymbol-id? x)
- (literal-id=? x (syntax (... ...))))))
-
-;;; data
-
-;;; strips all annotations from potentially circular reader output
-
-(define strip-annotation
- (lambda (x parent)
- (cond
- ((pair? x)
- (let ((new (cons #f #f)))
- (when parent (set-annotation-stripped! parent new))
- (set-car! new (strip-annotation (car x) #f))
- (set-cdr! new (strip-annotation (cdr x) #f))
- new))
- ((annotation? x)
- (or (annotation-stripped x)
- (strip-annotation (annotation-expression x) x)))
- ((vector? x)
- (let ((new (make-vector (vector-length x))))
- (when parent (set-annotation-stripped! parent new))
- (let loop ((i (- (vector-length x) 1)))
- (unless (fx< i 0)
- (vector-set! new i (strip-annotation (vector-ref x i) #f))
- (loop (fx- i 1))))
- new))
- (else x))))
-
-;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
-;;; on an annotation, strips the annotation as well.
-;;; since only the head of a list is annotated by the reader, not each pair
-;;; in the spine, we also check for pairs whose cars are annotated in case
-;;; we've been passed the cdr of an annotated list
-
-(define strip*
- (lambda (x w fn)
- (if (top-marked? w)
- (fn x)
- (let f ((x x))
- (cond
- ((syntax-object? x)
- (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x)))
- x
- (cons a d))))
- ((vector? x)
- (let ((old (vector->list x)))
- (let ((new (map f old)))
- (if (andmap eq? old new) x (list->vector new)))))
- (else x))))))
-
-(define strip
- (lambda (x w)
- (strip* x w
- (lambda (x)
- (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
- (strip-annotation x #f)
- x)))))
-
-;;; lexical variables
-
-(define gen-var
- (lambda (id)
- (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
- (if (annotation? id)
- (build-lexical-var (annotation-source id) (annotation-expression id))
- (build-lexical-var no-source id)))))
-
-(define lambda-var-list
- (lambda (vars)
- (let lvl ((vars vars) (ls '()) (w empty-wrap))
- (cond
- ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
- ((id? vars) (cons (wrap vars w) ls))
- ((null? vars) ls)
- ((syntax-object? vars)
- (lvl (syntax-object-expression vars)
- ls
- (join-wraps w (syntax-object-wrap vars))))
- ((annotation? vars)
- (lvl (annotation-expression vars) ls w))
- ; include anything else to be caught by subsequent error
- ; checking
- (else (cons vars ls))))))
-
-
-; must precede global-extends
-
-(set! $sc-put-cte
- (lambda (id b)
- (define put-token
- (lambda (id token)
- (define cons-id
- (lambda (id x)
- (if (not x) id (cons id x))))
- (define weed
- (lambda (id x)
- (if (pair? x)
- (if (bound-id=? (car x) id) ; could just check same-marks
- (weed id (cdr x))
- (cons-id (car x) (weed id (cdr x))))
- (if (or (not x) (bound-id=? x id))
- #f
- x))))
- (let ((sym (id-sym-name id)))
- (let ((x (weed id (getprop sym token))))
- (if (and (not x) (symbol? id))
- ; don't pollute property list when all we have is a plain
- ; top-level binding, since that's what's assumed anyway
- (remprop sym token)
- (putprop sym token (cons-id id x)))))))
- (define sc-put-module
- (lambda (exports token)
- (vfor-each
- (lambda (id) (put-token id token))
- exports)))
- (define (put-cte id binding)
- ;; making assumption here that all macros should be visible to the user and that system
- ;; globals don't come through here (primvars.ss sets up their properties)
- (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
- (putprop sym '*sc-expander* binding)))
- (let ((binding (or (sanitize-binding b) (error 'define-syntax "invalid transformer ~s" b))))
- (case (binding-type binding)
- ((module)
- (let ((iface (binding-value binding)))
- (sc-put-module (interface-exports iface) (interface-token iface)))
- (put-cte id binding))
- ((do-import) ; fake binding: id is module id, binding-value is import token
- (let ((token (binding-value b)))
- (let ((b (lookup (id-var-name id empty-wrap) null-env)))
- (case (binding-type b)
- ((module)
- (let ((iface (binding-value b)))
- (unless (eq? (interface-token iface) token)
- (syntax-error id "import mismatch for module"))
- (sc-put-module (interface-exports iface) '*top*)))
- (else (syntax-error id "import from unknown module"))))))
- (else (put-cte id binding))))))
-
-
-;;; core transformers
-
-(global-extend 'local-syntax 'letrec-syntax #t)
-(global-extend 'local-syntax 'let-syntax #f)
-
-
-(global-extend 'core 'fluid-let-syntax
- (lambda (e r w s)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? (syntax (var ...)))
- (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
- (for-each
- (lambda (id n)
- (case (binding-type (lookup n r))
- ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
- (syntax (var ...))
- names)
- (chi-body
- (syntax (e1 e2 ...))
- (source-wrap e w s)
- (extend-env*
- names
- (let ((trans-r (transformer-env r)))
- (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
- r)
- w)))
- (_ (syntax-error (source-wrap e w s))))))
-
-(global-extend 'core 'quote
- (lambda (e r w s)
- (syntax-case e ()
- ((_ e) (build-data s (strip (syntax e) w)))
- (_ (syntax-error (source-wrap e w s))))))
-
-(global-extend 'core 'syntax
- (let ()
- (define gen-syntax
- (lambda (src e r maps ellipsis?)
- (if (id? e)
- (let ((label (id-var-name e empty-wrap)))
- (let ((b (lookup label r)))
- (if (eq? (binding-type b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (binding-value b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values `(ref ,var) maps)))
- (if (ellipsis? e)
- (syntax-error src "misplaced ellipsis in syntax form")
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? (syntax dots))
- (gen-syntax src (syntax e) r maps (lambda (x) #f)))
- ((x dots . y)
- ; this could be about a dozen lines of code, except that we
- ; choose to handle (syntax (x ... ...)) forms
- (ellipsis? (syntax dots))
- (let f ((y (syntax y))
- (k (lambda (maps)
- (call-with-values
- (lambda ()
- (gen-syntax src (syntax x) r
- (cons '() maps) ellipsis?))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
- (values (gen-map x (car maps))
- (cdr maps))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? (syntax dots))
- (f (syntax y)
- (lambda (maps)
- (call-with-values
- (lambda () (k (cons '() maps)))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
- (values (gen-mappend x (car maps))
- (cdr maps))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis?))
- (lambda (y maps)
- (call-with-values
- (lambda () (k maps))
- (lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((x . y)
- (call-with-values
- (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
- (lambda (y maps) (values (gen-cons x y) maps))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
- (lambda (e maps) (values (gen-vector e) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-error src "missing ellipsis in syntax form")
- (call-with-values
- (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
- (lambda (outer-var outer-maps)
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps)))))))))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ; identity map equivalence:
- ; (map (lambda (x) x) y) == y
- (car actuals))
- ((andmap
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ; eta map equivalence:
- ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- (define gen-cons
- (lambda (x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y)))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-vector
- (lambda (x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
- ((map) (let ((ls (map regen (cdr x))))
- (build-application no-source
- (if (fx= (length ls) 2)
- (build-primref no-source 'map)
- ; really need to do our own checking here
- (build-primref no-source 2 'map)) ; require error check
- ls)))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
-
- (lambda (e r w s)
- (let ((e (source-wrap e w s)))
- (syntax-case e ()
- ((_ x)
- (call-with-values
- (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
- (lambda (e maps) (regen e))))
- (_ (syntax-error e)))))))
-
-
-(global-extend 'core 'lambda
- (lambda (e r w s)
- (syntax-case e ()
- ((_ . c)
- (chi-lambda-clause (source-wrap e w s) (syntax c) r w
- (lambda (vars body) (build-lambda s vars body)))))))
-
-
-(global-extend 'core 'letrec
- (lambda (e r w s)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
- (source-wrap e w s) "bound variable")
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (let ((w (make-binding-wrap ids labels w))
- (r (extend-var-env* labels new-vars r)))
- (build-letrec s
- new-vars
- (map (lambda (x) (chi x r w)) (syntax (val ...)))
- (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(global-extend 'core 'if
- (lambda (e r w s)
- (syntax-case e ()
- ((_ test then)
- (build-conditional s
- (chi (syntax test) r w)
- (chi (syntax then) r w)
- (chi-void)))
- ((_ test then else)
- (build-conditional s
- (chi (syntax test) r w)
- (chi (syntax then) r w)
- (chi (syntax else) r w)))
- (_ (syntax-error (source-wrap e w s))))))
-
-
-
-(global-extend 'set! 'set! '())
-
-(global-extend 'begin 'begin '())
-
-(global-extend 'module-key 'module '())
-(global-extend 'import 'import #f)
-(global-extend 'import 'import-only #t)
-
-(global-extend 'define 'define '())
-
-(global-extend 'define-syntax 'define-syntax '())
-
-(global-extend 'eval-when 'eval-when '())
-
-(global-extend 'core 'syntax-case
- (let ()
- (define convert-pattern
- ; accepts pattern & keys
- ; returns syntax-dispatch pattern & ids
- (lambda (pattern keys)
- (let cvt ((p pattern) (n 0) (ids '()))
- (if (id? p)
- (if (bound-id-member? p keys)
- (values (vector 'free-id p) ids)
- (values 'any (cons (cons p n) ids)))
- (syntax-case p ()
- ((x dots)
- (ellipsis? (syntax dots))
- (call-with-values
- (lambda () (cvt (syntax x) (fx+ n 1) ids))
- (lambda (p ids)
- (values (if (eq? p 'any) 'each-any (vector 'each p))
- ids))))
- ((x . y)
- (call-with-values
- (lambda () (cvt (syntax y) n ids))
- (lambda (y ids)
- (call-with-values
- (lambda () (cvt (syntax x) n ids))
- (lambda (x ids)
- (values (cons x y) ids))))))
- (() (values '() ids))
- (#(x ...)
- (call-with-values
- (lambda () (cvt (syntax (x ...)) n ids))
- (lambda (p ids) (values (vector 'vector p) ids))))
- (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
-
- (define build-dispatch-call
- (lambda (pvars exp y r)
- (let ((ids (map car pvars)) (levels (map cdr pvars)))
- (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application no-source
- (build-primref no-source 'apply)
- (list (build-lambda no-source new-vars
- (chi exp
- (extend-env*
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)))
- y))))))
-
- (define gen-clause
- (lambda (x keys clauses r pat fender exp)
- (call-with-values
- (lambda () (convert-pattern pat keys))
- (lambda (p pvars)
- (cond
- ((not (distinct-bound-ids? (map car pvars)))
- (invalid-ids-error (map car pvars) pat "pattern variable"))
- ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-error pat
- "misplaced ellipsis in syntax-case pattern"))
- (else
- (let ((y (gen-var 'tmp)))
- ; fat finger binding and references to temp variable y
- (build-application no-source
- (build-lambda no-source (list y)
- (let-syntax ((y (identifier-syntax
- (build-lexical-reference 'value no-source y))))
- (build-conditional no-source
- (syntax-case fender ()
- (#t y)
- (_ (build-conditional no-source
- y
- (build-dispatch-call pvars fender y r)
- (build-data no-source #f))))
- (build-dispatch-call pvars exp y r)
- (gen-syntax-case x keys clauses r))))
- (list (if (eq? p 'any)
- (build-application no-source
- (build-primref no-source 'list)
- (list (build-lexical-reference no-source 'value x)))
- (build-application no-source
- (build-primref no-source '$syntax-dispatch)
- (list (build-lexical-reference no-source 'value x)
- (build-data no-source p)))))))))))))
-
- (define gen-syntax-case
- (lambda (x keys clauses r)
- (if (null? clauses)
- (build-application no-source
- (build-primref no-source 'syntax-error)
- (list (build-lexical-reference 'value no-source x)))
- (syntax-case (car clauses) ()
- ((pat exp)
- (if (and (id? (syntax pat))
- (not (bound-id-member? (syntax pat) keys))
- (not (ellipsis? (syntax pat))))
- (let ((label (gen-label))
- (var (gen-var (syntax pat))))
- (build-application no-source
- (build-lambda no-source (list var)
- (chi (syntax exp)
- (extend-env label (make-binding 'syntax `(,var . 0)) r)
- (make-binding-wrap (syntax (pat))
- (list label) empty-wrap)))
- (list (build-lexical-reference 'value no-source x))))
- (gen-clause x keys (cdr clauses) r
- (syntax pat) #t (syntax exp))))
- ((pat fender exp)
- (gen-clause x keys (cdr clauses) r
- (syntax pat) (syntax fender) (syntax exp)))
- (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
-
- (lambda (e r w s)
- (let ((e (source-wrap e w s)))
- (syntax-case e ()
- ((_ val (key ...) m ...)
- (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
- (syntax (key ...)))
- (let ((x (gen-var 'tmp)))
- ; fat finger binding and references to temp variable x
- (build-application s
- (build-lambda no-source (list x)
- (gen-syntax-case x
- (syntax (key ...)) (syntax (m ...))
- r))
- (list (chi (syntax val) r empty-wrap))))
- (syntax-error e "invalid literals list in"))))))))
-
-;;; The portable sc-expand seeds chi-top's mode m with 'e (for
-;;; evaluating) and esew (which stands for "eval syntax expanders
-;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
-;;; if we are compiling a file, and esew is set to
-;;; (eval-syntactic-expanders-when), which defaults to the list
-;;; '(compile load eval). This means that, by default, top-level
-;;; syntactic definitions are evaluated immediately after they are
-;;; expanded, and the expanded definitions are also residualized into
-;;; the object file if we are compiling a file.
-(set! sc-expand
- (let ((m 'e) (esew '(eval))
- (user-ribcage
- (let ((ribcage (make-empty-ribcage)))
- (extend-ribcage-subst! ribcage '*top*)
- ribcage)))
- (let ((user-top-wrap
- (make-wrap (wrap-marks top-wrap)
- (cons user-ribcage (wrap-subst top-wrap)))))
- (lambda (x)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top x null-env user-top-wrap m esew user-ribcage))))))
-
-(set! identifier?
- (lambda (x)
- (nonsymbol-id? x)))
-
-(set! datum->syntax-object
- (lambda (id datum)
- (arg-check nonsymbol-id? id 'datum->syntax-object)
- (make-syntax-object datum (syntax-object-wrap id))))
-
-(set! syntax-object->datum
- ; accepts any object, since syntax objects may consist partially
- ; or entirely of unwrapped, nonsymbolic data
- (lambda (x)
- (strip x empty-wrap)))
-
-(set! generate-temporaries
- (lambda (ls)
- (arg-check list? ls 'generate-temporaries)
- (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
-
-(set! free-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'free-identifier=?)
- (arg-check nonsymbol-id? y 'free-identifier=?)
- (free-id=? x y)))
-
-(set! bound-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'bound-identifier=?)
- (arg-check nonsymbol-id? y 'bound-identifier=?)
- (bound-id=? x y)))
-
-
-(set! syntax-error
- (lambda (object . messages)
- (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
- (let ((message (if (null? messages)
- "invalid syntax"
- (apply string-append messages))))
- (error-hook #f message (strip object empty-wrap)))))
-
-;;; syntax-dispatch expects an expression and a pattern. If the expression
-;;; matches the pattern a list of the matching expressions for each
-;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
-;;; not work on r4rs implementations that violate the ieee requirement
-;;; that #f and () be distinct.)
-
-;;; The expression is matched with the pattern as follows:
-
-;;; pattern: matches:
-;;; () empty list
-;;; any anything
-;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
-;;; each-any (any*)
-;;; #(free-id <key>) <key> with free-identifier=?
-;;; #(each <pattern>) (<pattern>*)
-;;; #(vector <pattern>) (list->vector <pattern>)
-;;; #(atom <object>) <object> with "equal?"
-
-;;; Vector cops out to pair under assumption that vectors are rare. If
-;;; not, should convert to:
-;;; #(vector <pattern>*) #(<pattern>*)
-
-(let ()
-
-(define match-each
- (lambda (e p w)
- (cond
- ((annotation? e)
- (match-each (annotation-expression e) p w))
- ((pair? e)
- (let ((first (match (car e) p w '())))
- (and first
- (let ((rest (match-each (cdr e) p w)))
- (and rest (cons first rest))))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))))
- (else #f))))
-
-(define match-each-any
- (lambda (e w)
- (cond
- ((annotation? e)
- (match-each-any (annotation-expression e) w))
- ((pair? e)
- (let ((l (match-each-any (cdr e) w)))
- (and l (cons (wrap (car e) w) l))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))))
- (else #f))))
-
-(define match-empty
- (lambda (p r)
- (cond
- ((null? p) r)
- ((eq? p 'any) (cons '() r))
- ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
- ((eq? p 'each-any) (cons '() r))
- (else
- (case (vector-ref p 0)
- ((each) (match-empty (vector-ref p 1) r))
- ((free-id atom) r)
- ((vector) (match-empty (vector-ref p 1) r)))))))
-
-(define match*
- (lambda (e p w r)
- (cond
- ((null? p) (and (null? e) r))
- ((pair? p)
- (and (pair? e) (match (car e) (car p) w
- (match (cdr e) (cdr p) w r))))
- ((eq? p 'each-any)
- (let ((l (match-each-any e w))) (and l (cons l r))))
- (else
- (case (vector-ref p 0)
- ((each)
- (if (null? e)
- (match-empty (vector-ref p 1) r)
- (let ((l (match-each e (vector-ref p 1) w)))
- (and l
- (let collect ((l l))
- (if (null? (car l))
- r
- (cons (map car l) (collect (map cdr l)))))))))
- ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
- ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
- ((vector)
- (and (vector? e)
- (match (vector->list e) (vector-ref p 1) w r))))))))
-
-(define match
- (lambda (e p w r)
- (cond
- ((not r) #f)
- ((eq? p 'any) (cons (wrap e w) r))
- ((syntax-object? e)
- (match*
- (unannotate (syntax-object-expression e))
- p
- (join-wraps w (syntax-object-wrap e))
- r))
- (else (match* (unannotate e) p w r)))))
-
-(set! $syntax-dispatch
- (lambda (e p)
- (cond
- ((eq? p 'any) (list e))
- ((syntax-object? e)
- (match* (unannotate (syntax-object-expression e))
- p (syntax-object-wrap e) '()))
- (else (match* (unannotate e) p empty-wrap '())))))
-))
-
-
-(define-syntax with-syntax
- (lambda (x)
- (syntax-case x ()
- ((_ () e1 e2 ...)
- (syntax (begin e1 e2 ...)))
- ((_ ((out in)) e1 e2 ...)
- (syntax (syntax-case in () (out (begin e1 e2 ...)))))
- ((_ ((out in) ...) e1 e2 ...)
- (syntax (syntax-case (list in ...) ()
- ((out ...) (begin e1 e2 ...))))))))
-
-(define-syntax syntax-rules
- (lambda (x)
- (syntax-case x ()
- ((_ (k ...) ((keyword . pattern) template) ...)
- (syntax (lambda (x)
- (syntax-case x (k ...)
- ((dummy . pattern) (syntax template))
- ...)))))))
-
-(define-syntax or
- (lambda (x)
- (syntax-case x ()
- ((_) (syntax #f))
- ((_ e) (syntax e))
- ((_ e1 e2 e3 ...)
- (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
-
-(define-syntax and
- (lambda (x)
- (syntax-case x ()
- ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
- ((_ e) (syntax e))
- ((_) (syntax #t)))))
-
-(define-syntax let
- (lambda (x)
- (syntax-case x ()
- ((_ ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
- (syntax ((lambda (x ...) e1 e2 ...) v ...)))
- ((_ f ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (f x ...)))
- (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
- v ...))))))
-
-(define-syntax let*
- (lambda (x)
- (syntax-case x ()
- ((let* ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
- (let f ((bindings (syntax ((x v) ...))))
- (if (null? bindings)
- (syntax (let () e1 e2 ...))
- (with-syntax ((body (f (cdr bindings)))
- (binding (car bindings)))
- (syntax (let (binding) body)))))))))
-
-(define-syntax cond
- (lambda (x)
- (syntax-case x ()
- ((_ m1 m2 ...)
- (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
- (if (null? clauses)
- (syntax-case clause (else =>)
- ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
- ((e0) (syntax (let ((t e0)) (if t t))))
- ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
- ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
- (_ (syntax-error x)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else =>)
- ((e0) (syntax (let ((t e0)) (if t t rest))))
- ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
- ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
- (_ (syntax-error x))))))))))
-
-(define-syntax do
- (lambda (orig-x)
- (syntax-case orig-x ()
- ((_ ((var init . step) ...) (e0 e1 ...) c ...)
- (with-syntax (((step ...)
- (map (lambda (v s)
- (syntax-case s ()
- (() v)
- ((e) (syntax e))
- (_ (syntax-error orig-x))))
- (syntax (var ...))
- (syntax (step ...)))))
- (syntax-case (syntax (e1 ...)) ()
- (() (syntax (let doloop ((var init) ...)
- (if (not e0)
- (begin c ... (doloop step ...))))))
- ((e1 e2 ...)
- (syntax (let doloop ((var init) ...)
- (if e0
- (begin e1 e2 ...)
- (begin c ... (doloop step ...))))))))))))
-
-(define-syntax quasiquote
- (letrec
- ; these are here because syntax-case uses literal-identifier=?,
- ; and we want the more precise free-identifier=?
- ((isquote? (lambda (x)
- (and (identifier? x)
- (free-identifier=? x (syntax quote)))))
- (islist? (lambda (x)
- (and (identifier? x)
- (free-identifier=? x (syntax list)))))
- (iscons? (lambda (x)
- (and (identifier? x)
- (free-identifier=? x (syntax cons)))))
- (quote-nil? (lambda (x)
- (syntax-case x ()
- ((quote? ()) (isquote? (syntax quote?)))
- (_ #f))))
- (quasilist*
- (lambda (x y)
- (let f ((x x))
- (if (null? x)
- y
- (quasicons (car x) (f (cdr x)))))))
- (quasicons
- (lambda (x y)
- (with-syntax ((x x) (y y))
- (syntax-case (syntax y) ()
- ((quote? dy)
- (isquote? (syntax quote?))
- (syntax-case (syntax x) ()
- ((quote? dx)
- (isquote? (syntax quote?))
- (syntax (quote (dx . dy))))
- (_ (if (null? (syntax dy))
- (syntax (list x))
- (syntax (cons x y))))))
- ((listp . stuff)
- (islist? (syntax listp))
- (syntax (list x . stuff)))
- (else (syntax (cons x y)))))))
- (quasiappend
- (lambda (x y)
- (let ((ls (let f ((x x))
- (if (null? x)
- (if (quote-nil? y)
- '()
- (list y))
- (if (quote-nil? (car x))
- (f (cdr x))
- (cons (car x) (f (cdr x))))))))
- (cond
- ((null? ls) (syntax (quote ())))
- ((null? (cdr ls)) (car ls))
- (else (with-syntax (((p ...) ls))
- (syntax (append p ...))))))))
- (quasivector
- (lambda (x)
- (with-syntax ((pat-x x))
- (syntax-case (syntax pat-x) ()
- ((quote? (x ...))
- (isquote? (syntax quote?))
- (syntax (quote #(x ...))))
- (_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls))))
- (syntax-case x ()
- ((quote? (x ...))
- (isquote? (syntax quote?))
- (k (syntax ((quote x) ...))))
- ((listp x ...)
- (islist? (syntax listp))
- (k (syntax (x ...))))
- ((cons? x y)
- (iscons? (syntax cons?))
- (f (syntax y) (lambda (ls) (k (cons (syntax x) ls)))))
- (else
- (syntax (list->vector pat-x))))))))))
- (quasi
- (lambda (p lev)
- (syntax-case p (unquote unquote-splicing quasiquote)
- ((unquote p)
- (if (= lev 0)
- (syntax p)
- (quasicons (syntax (quote unquote))
- (quasi (syntax (p)) (- lev 1)))))
- (((unquote p ...) . q)
- (if (= lev 0)
- (quasilist* (syntax (p ...)) (quasi (syntax q) lev))
- (quasicons (quasicons (syntax (quote unquote))
- (quasi (syntax (p ...)) (- lev 1)))
- (quasi (syntax q) lev))))
- (((unquote-splicing p ...) . q)
- (if (= lev 0)
- (quasiappend (syntax (p ...)) (quasi (syntax q) lev))
- (quasicons (quasicons (syntax (quote unquote-splicing))
- (quasi (syntax (p ...)) (- lev 1)))
- (quasi (syntax q) lev))))
- ((quasiquote p)
- (quasicons (syntax (quote quasiquote))
- (quasi (syntax (p)) (+ lev 1))))
- ((p . q)
- (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
- (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
- (p (syntax (quote p)))))))
- (lambda (x)
- (syntax-case x ()
- ((_ e) (quasi (syntax e) 0))))))
-
-(define-syntax include
- (lambda (x)
- (define read-file
- (lambda (fn k)
- (let ((p (open-input-file fn)))
- (let f ()
- (let ((x (read p)))
- (if (eof-object? x)
- (begin (close-input-port p) '())
- (cons (datum->syntax-object k x) (f))))))))
- (syntax-case x ()
- ((k filename)
- (let ((fn (syntax-object->datum (syntax filename))))
- (with-syntax (((exp ...) (read-file fn (syntax k))))
- (syntax (begin exp ...))))))))
-
-(define-syntax unquote
- (lambda (x)
- (syntax-case x ()
- ((_ e ...)
- (syntax-error x
- "expression not valid outside of quasiquote")))))
-
-(define-syntax unquote-splicing
- (lambda (x)
- (syntax-case x ()
- ((_ e ...)
- (syntax-error x
- "expression not valid outside of quasiquote")))))
-
-(define-syntax case
- (lambda (x)
- (syntax-case x ()
- ((_ e m1 m2 ...)
- (with-syntax
- ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
- (if (null? clauses)
- (syntax-case clause (else)
- ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-error x)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else)
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...))
- (begin e1 e2 ...)
- rest)))
- (_ (syntax-error x))))))))
- (syntax (let ((t e)) body)))))))
-
-(define-syntax identifier-syntax
- (lambda (x)
- (syntax-case x (set!)
- ((_ e)
- (syntax
- (lambda (x)
- (syntax-case x ()
- (id
- (identifier? (syntax id))
- (syntax e))
- ((_ x (... ...))
- (syntax (e x (... ...))))))))
- ((_ (id exp1) ((set! var val) exp2))
- (and (identifier? (syntax id)) (identifier? (syntax var)))
- (syntax
- (cons 'macro!
- (lambda (x)
- (syntax-case x (set!)
- ((set! var val) (syntax exp2))
- ((id x (... ...)) (syntax (exp1 x (... ...))))
- (id (identifier? (syntax id)) (syntax exp1))))))))))
-
+++ /dev/null
-;;; Guile R5RS
-
-;; Copyright (C) 2001 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
-
-;;; Code:
-
-(define-module (language r5rs spec)
- #:use-module (system base language)
- #:use-module (language r5rs expand)
- #:use-module (language r5rs translate)
- #:export (r5rs))
-
-\f
-;;;
-;;; Translator
-;;;
-
-(define (translate x) (if (pair? x) (translate-pair x) x))
-
-(define (translate-pair x)
- (let ((head (car x)) (rest (cdr x)))
- (case head
- ((quote) (cons '@quote rest))
- ((define set! if and or begin)
- (cons (symbol-append '@ head) (map translate rest)))
- ((let let* letrec)
- (cons* (symbol-append '@ head)
- (map (lambda (b) (cons (car b) (map translate (cdr b))))
- (car rest))
- (map translate (cdr rest))))
- ((lambda)
- (cons* '@lambda (car rest) (map translate (cdr rest))))
- (else
- (cons (translate head) (map translate rest))))))
-
-\f
-;;;
-;;; Language definition
-;;;
-
-(define-language r5rs
- #:title "Standard Scheme (R5RS + syntax-case)"
- #:version "0.3"
- #:reader read
- #:expander expand
- #:translator translate
- #:printer write
-;; #:environment (global-ref 'Language::R5RS::core)
- )
+++ /dev/null
-;;; Guile Scheme specification
-
-;; Copyright (C) 2001 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
-
-;;; Code:
-
-(define-module (language scheme compile-ghil)
- #:use-module (system base pmatch)
- #:use-module (system base language)
- #:use-module (language ghil)
- #:use-module (language scheme inline)
- #:use-module (system vm objcode)
- #:use-module (ice-9 receive)
- #:use-module (ice-9 optargs)
- #:use-module (language tree-il)
- #:use-module ((system base compile) #:select (syntax-error))
- #:export (compile-ghil translate-1
- *translate-table* define-scheme-translator))
-
-;;; environment := #f
-;;; | MODULE
-;;; | COMPILE-ENV
-;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS)
-(define (cenv-module env)
- (cond ((not env) #f)
- ((module? env) env)
- ((and (pair? env) (module? (car env))) (car env))
- (else (error "bad environment" env))))
-
-(define (cenv-ghil-env env)
- (cond ((not env) (make-ghil-toplevel-env))
- ((module? env) (make-ghil-toplevel-env))
- ((pair? env)
- (if (struct? (cadr env))
- (cadr env)
- (ghil-env-dereify (cadr env))))
- (else (error "bad environment" env))))
-
-(define (cenv-externals env)
- (cond ((not env) '())
- ((module? env) '())
- ((pair? env) (cddr env))
- (else (error "bad environment" env))))
-
-(define (make-cenv module lexicals externals)
- (cons module (cons lexicals externals)))
-
-\f
-
-(define (compile-ghil x e opts)
- (save-module-excursion
- (lambda ()
- (and=> (cenv-module e) set-current-module)
- (call-with-ghil-environment (cenv-ghil-env e) '()
- (lambda (env vars)
- (let ((x (tree-il->scheme
- (sc-expand x 'c '(compile load eval)))))
- (let ((x (make-ghil-lambda env #f vars #f '()
- (translate-1 env #f x)))
- (cenv (make-cenv (current-module)
- (ghil-env-parent env)
- (if e (cenv-externals e) '()))))
- (values x cenv cenv))))))))
-
-\f
-;;;
-;;; Translator
-;;;
-
-(define *forbidden-primitives*
- ;; Guile's `procedure->macro' family is evil because it crosses the
- ;; compilation boundary. One solution might be to evaluate calls to
- ;; `procedure->memoizing-macro' at compilation time, but it may be more
- ;; compicated than that.
- '(procedure->syntax procedure->macro))
-
-;; Looks up transformers relative to the current module at
-;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
-;;
-;; FIXME shadowing lexicals?
-(define (lookup-transformer head retrans)
- (define (module-ref/safe mod sym)
- (and mod
- (and=> (module-variable mod sym)
- (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var))))))
- (let* ((mod (current-module))
- (val (cond
- ((symbol? head) (module-ref/safe mod head))
- ((pmatch head
- ((@ ,modname ,sym)
- (module-ref/safe (resolve-interface modname) sym))
- ((@@ ,modname ,sym)
- (module-ref/safe (resolve-module modname) sym))
- (else #f)))
- (else #f))))
- (cond
- ((hashq-ref *translate-table* val))
-
- ((macro? val)
- (syntax-error #f "unknown kind of macro" head))
-
- (else #f))))
-
-(define (translate-1 e l x)
- (let ((l (or l (location x))))
- (define (retrans x) (translate-1 e #f x))
- (define (retrans/loc x) (translate-1 e (or (location x) l) x))
- (cond ((pair? x)
- (let ((head (car x)) (tail (cdr x)))
- (cond
- ((lookup-transformer head retrans/loc)
- => (lambda (t) (t e l x)))
-
- ;; FIXME: lexical/module overrides of forbidden primitives
- ((memq head *forbidden-primitives*)
- (syntax-error l (format #f "`~a' is forbidden" head)
- (cons head tail)))
-
- (else
- (let ((tail (map retrans tail)))
- (or (and (symbol? head)
- (try-inline-with-env e l (cons head tail)))
- (make-ghil-call e l (retrans head) tail)))))))
-
- ((symbol? x)
- (make-ghil-ref e l (ghil-var-for-ref! e x)))
-
- ;; fixme: non-self-quoting objects like #<foo>
- (else
- (make-ghil-quote e l x)))))
-
-(define (valid-bindings? bindings . it-is-for-do)
- (define (valid-binding? b)
- (pmatch b
- ((,sym ,var) (guard (symbol? sym)) #t)
- ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
- (else #f)))
- (and (list? bindings) (and-map valid-binding? bindings)))
-
-(define *translate-table* (make-hash-table))
-
-(define-macro (-> form)
- `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
-
-(define-macro (define-scheme-translator sym . clauses)
- `(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
- (module-ref (current-module) ',sym)
- (lambda (e l exp)
- (define (retrans x)
- ((@ (language scheme compile-ghil) translate-1)
- e
- (or ((@@ (language scheme compile-ghil) location) x) l)
- x))
- (define syntax-error (@ (system base compile) syntax-error))
- (pmatch (cdr exp)
- ,@clauses
- ,@(if (assq 'else clauses) '()
- `((else
- (syntax-error l (format #f "bad ~A" ',sym) exp))))))))
-
-(define-scheme-translator quote
- ;; (quote OBJ)
- ((,obj)
- (-> (quote obj))))
-
-(define-scheme-translator quasiquote
- ;; (quasiquote OBJ)
- ((,obj)
- (-> (quasiquote (trans-quasiquote e l obj 0)))))
-
-(define-scheme-translator define
- ;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name)
- (ghil-toplevel-env? (ghil-env-parent e)))
- (-> (define (ghil-var-define! (ghil-env-parent e) name)
- (maybe-name-value! (retrans val) name))))
- ;; (define (NAME FORMALS...) BODY...)
- (((,name . ,formals) . ,body) (guard (symbol? name))
- ;; -> (define NAME (lambda FORMALS BODY...))
- (retrans `(define ,name (lambda ,formals ,@body)))))
-
-(define-scheme-translator set!
- ;; (set! NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> (set (ghil-var-for-set! e name) (retrans val))))
-
- ;; FIXME: Would be nice to verify the values of @ and @@ relative
- ;; to imported modules...
- (((@ ,modname ,name) ,val) (guard (symbol? name)
- (list? modname)
- (and-map symbol? modname)
- (not (ghil-var-is-bound? e '@)))
- (-> (set (ghil-var-at-module! e modname name #t) (retrans val))))
-
- (((@@ ,modname ,name) ,val) (guard (symbol? name)
- (list? modname)
- (and-map symbol? modname)
- (not (ghil-var-is-bound? e '@@)))
- (-> (set (ghil-var-at-module! e modname name #f) (retrans val))))
-
- ;; (set! (NAME ARGS...) VAL)
- (((,name . ,args) ,val) (guard (symbol? name))
- ;; -> ((setter NAME) ARGS... VAL)
- (retrans `((setter ,name) . (,@args ,val)))))
-
-(define-scheme-translator if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (-> (if (retrans test) (retrans then) (retrans '(begin)))))
- ((,test ,then ,else)
- (-> (if (retrans test) (retrans then) (retrans else)))))
-
-(define-scheme-translator and
- ;; (and EXPS...)
- (,tail
- (-> (and (map retrans tail)))))
-
-(define-scheme-translator or
- ;; (or EXPS...)
- (,tail
- (-> (or (map retrans tail)))))
-
-(define-scheme-translator begin
- ;; (begin EXPS...)
- (,tail
- (-> (begin (map retrans tail)))))
-
-(define-scheme-translator let
- ;; (let NAME ((SYM VAL) ...) BODY...)
- ((,name ,bindings . ,body) (guard (symbol? name)
- (valid-bindings? bindings))
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
- (,name ,@(map cadr bindings)))))
-
- ;; (let () BODY...)
- ((() . ,body)
- ;; Note: this differs from `begin'
- (-> (begin (list (trans-body e l body)))))
-
- ;; (let ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (let ((vals (map (lambda (b)
- (maybe-name-value! (retrans (cadr b)) (car b)))
- bindings)))
- (call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (-> (bind vars vals (trans-body e l body))))))))
-
-(define-scheme-translator let*
- ;; (let* ((SYM VAL) ...) BODY...)
- ((() . ,body)
- (retrans `(let () ,@body)))
- ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
- (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
-
-(define-scheme-translator letrec
- ;; (letrec ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (let ((vals (map (lambda (b)
- (maybe-name-value!
- (retrans (cadr b)) (car b)))
- bindings)))
- (-> (bind vars vals (trans-body e l body))))))))
-
-(define-scheme-translator cond
- ;; (cond (CLAUSE BODY...) ...)
- (() (retrans '(begin)))
- (((else . ,body)) (retrans `(begin ,@body)))
- (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
- (((,test => ,proc) . ,rest)
- ;; FIXME hygiene!
- (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
- (((,test . ,body) . ,rest)
- (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
-
-(define-scheme-translator case
- ;; (case EXP ((KEY...) BODY...) ...)
- ((,exp . ,clauses)
- (retrans
- ;; FIXME hygiene!
- `(let ((_t ,exp))
- ,(let loop ((ls clauses))
- (cond ((null? ls) '(begin))
- ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
- (else `(if (memv _t ',(caar ls))
- (begin ,@(cdar ls))
- ,(loop (cdr ls))))))))))
-
-(define-scheme-translator do
- ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
- ((,bindings (,test . ,result) . ,body)
- (let ((sym (map car bindings))
- (val (map cadr bindings))
- (update (map cddr bindings)))
- (define (next s x) (if (pair? x) (car x) s))
- (retrans
- ;; FIXME hygiene!
- `(letrec ((_l (lambda ,sym
- (if ,test
- (begin ,@result)
- (begin ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@val))))))
-
-(define-scheme-translator lambda
- ;; (lambda FORMALS BODY...)
- ((,formals . ,body)
- (receive (syms rest) (parse-formals formals)
- (call-with-ghil-environment e syms
- (lambda (e vars)
- (receive (meta body) (parse-lambda-meta body)
- (-> (lambda vars rest meta (trans-body e l body)))))))))
-
-(define-scheme-translator delay
- ;; FIXME not hygienic
- ((,expr)
- (retrans `(make-promise (lambda () ,expr)))))
-
-(define-scheme-translator @
- ((,modname ,sym)
- (-> (ref (ghil-var-at-module! e modname sym #t)))))
-
-(define-scheme-translator @@
- ((,modname ,sym)
- (-> (ref (ghil-var-at-module! e modname sym #f)))))
-
-(define *the-compile-toplevel-symbol* 'compile-toplevel)
-(define-scheme-translator eval-when
- ((,when . ,body) (guard (list? when) (and-map symbol? when))
- (if (memq 'compile when)
- (primitive-eval `(begin . ,body)))
- (if (memq 'load when)
- (retrans `(begin . ,body))
- (retrans `(begin)))))
-
-(define-scheme-translator apply
- ;; FIXME: not hygienic, relies on @apply not being shadowed
- (,args (retrans `(@apply ,@args))))
-
-;; FIXME: we could add inliners for `list' and `vector'
-
-(define-scheme-translator @apply
- ((,proc ,arg1 . ,args)
- (let ((args (cons (retrans arg1) (map retrans args))))
- (cond ((and (symbol? proc)
- (not (ghil-var-is-bound? e proc))
- (and=> (module-variable (current-module) proc)
- (lambda (var)
- (and (variable-bound? var)
- (lookup-apply-transformer (variable-ref var))))))
- ;; that is, a variable, not part of this compilation
- ;; unit, but defined in the toplevel environment, and has
- ;; an apply transformer registered
- => (lambda (t) (t e l args)))
- (else
- (-> (inline 'apply (cons (retrans proc) args))))))))
-
-(define-scheme-translator call-with-values
- ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
- ((,producer ,consumer)
- (retrans `(@call-with-values ,producer ,consumer)))
- (else #f))
-
-(define-scheme-translator @call-with-values
- ((,producer ,consumer)
- (-> (mv-call (retrans producer) (retrans consumer)))))
-
-(define-scheme-translator call-with-current-continuation
- ;; FIXME: not hygienic, relies on @call-with-current-continuation
- ;; not being shadowed
- ((,proc)
- (retrans `(@call-with-current-continuation ,proc)))
- (else #f))
-
-(define-scheme-translator @call-with-current-continuation
- ((,proc)
- (-> (inline 'call/cc (list (retrans proc))))))
-
-(define-scheme-translator receive
- ((,formals ,producer-exp . ,body)
- ;; Lovely, self-referential usage. Not strictly necessary, the
- ;; macro would do the trick; but it's good to test the mv-bind
- ;; code.
- (receive (syms rest) (parse-formals formals)
- (let ((producer (retrans `(lambda () ,producer-exp))))
- (call-with-ghil-bindings e syms
- (lambda (vars)
- (-> (mv-bind producer vars rest
- (trans-body e l body)))))))))
-
-(define-scheme-translator values
- ((,x) (retrans x))
- (,args
- (-> (values (map retrans args)))))
-
-(define (lookup-apply-transformer proc)
- (cond ((eq? proc values)
- (lambda (e l args)
- (-> (values* args))))
- (else #f)))
-
-(define (trans-quasiquote e l x level)
- (cond ((not (pair? x)) x)
- ((memq (car x) '(unquote unquote-splicing))
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj)
- (cond
- ((zero? level)
- (if (eq? (car x) 'unquote)
- (-> (unquote (translate-1 e l obj)))
- (-> (unquote-splicing (translate-1 e l obj)))))
- (else
- (list (car x) (trans-quasiquote e l obj (1- level))))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- ((eq? (car x) 'quasiquote)
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- (else (cons (trans-quasiquote e l (car x) level)
- (trans-quasiquote e l (cdr x) level)))))
-
-(define (trans-body e l body)
- (define (define->binding df)
- (pmatch (cdr df)
- ((,name ,val) (guard (symbol? name)) (list name val))
- (((,name . ,formals) . ,body) (guard (symbol? name))
- (list name `(lambda ,formals ,@body)))
- (else (syntax-error (location df) "bad define" df))))
- ;; main
- (let loop ((ls body) (ds '()))
- (pmatch ls
- (() (syntax-error l "bad body" body))
- (((define . _) . _)
- (loop (cdr ls) (cons (car ls) ds)))
- (else
- (if (null? ds)
- (translate-1 e l `(begin ,@ls))
- (translate-1 e l `(letrec ,(map define->binding ds) ,@ls)))))))
-
-(define (parse-formals formals)
- (cond
- ;; (lambda x ...)
- ((symbol? formals) (values (list formals) #t))
- ;; (lambda (x y z) ...)
- ((list? formals) (values formals #f))
- ;; (lambda (x y . z) ...)
- ((pair? formals)
- (let loop ((l formals) (v '()))
- (if (pair? l)
- (loop (cdr l) (cons (car l) v))
- (values (reverse! (cons l v)) #t))))
- (else (syntax-error (location formals) "bad formals" formals))))
-
-(define (parse-lambda-meta body)
- (cond ((or (null? body) (null? (cdr body))) (values '() body))
- ((string? (car body))
- (values `((documentation . ,(car body))) (cdr body)))
- (else (values '() body))))
-
-(define (maybe-name-value! val name)
- (cond
- ((ghil-lambda? val)
- (if (not (assq-ref (ghil-lambda-meta val) 'name))
- (set! (ghil-lambda-meta val)
- (acons 'name name (ghil-lambda-meta val))))))
- val)
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
;;; Guile Scheme specification
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 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
;;; environment := #f
;;; | MODULE
-;;; | COMPILE-ENV
-;;; compile-env := (MODULE LEXICALS . EXTERNALS)
-(define (cenv-module env)
- (cond ((not env) #f)
- ((module? env) env)
- ((and (pair? env) (module? (car env))) (car env))
- (else (error "bad environment" env))))
-
-(define (cenv-lexicals env)
- (cond ((not env) '())
- ((module? env) '())
- ((pair? env) (cadr env))
- (else (error "bad environment" env))))
-
-(define (cenv-externals env)
- (cond ((not env) '())
- ((module? env) '())
- ((pair? env) (cddr env))
- (else (error "bad environment" env))))
-
-(define (make-cenv module lexicals externals)
- (cons module (cons lexicals externals)))
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
(define (compile-tree-il x e opts)
(save-module-excursion
(lambda ()
- (and=> (cenv-module e) set-current-module)
+ (set-current-module e)
(let* ((x (sc-expand x 'c '(compile load eval)))
- (cenv (make-cenv (current-module)
- (cenv-lexicals e) (cenv-externals e))))
+ (cenv (current-module)))
(values x cenv cenv)))))
+++ /dev/null
-;;; GHIL macros
-
-;; Copyright (C) 2001 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
-
-;;; Code:
-
-(define-module (language scheme inline)
- #:use-module (system base syntax)
- #:use-module (language ghil)
- #:use-module (srfi srfi-16)
- #:export (*inline-table* define-inline try-inline try-inline-with-env))
-
-(define *inline-table* '())
-
-(define-macro (define-inline sym . clauses)
- (define (inline-args args)
- (let lp ((in args) (out '()))
- (cond ((null? in) `(list ,@(reverse out)))
- ((symbol? in) `(cons* ,@(reverse out) ,in))
- ((pair? (car in))
- (lp (cdr in)
- (cons `(or (try-inline ,(caar in) ,(inline-args (cdar in)))
- (error "what" ',(car in)))
- out)))
- ((symbol? (car in))
- ;; assume it's locally bound
- (lp (cdr in) (cons (car in) out)))
- ((number? (car in))
- (lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out)))
- (else
- (error "what what" (car in))))))
- (define (consequent exp)
- (cond
- ((pair? exp)
- `(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp))))
- ((symbol? exp)
- ;; assume locally bound
- exp)
- ((number? exp)
- `(make-ghil-quote #f #f ,exp))
- (else (error "bad consequent yall" exp))))
- `(set! (@ (language scheme inline) *inline-table*)
- (assq-set! (@ (language scheme inline) *inline-table*)
- ,sym
- (let ((make-ghil-inline (@ (language ghil) make-ghil-inline))
- (make-ghil-quote (@ (language ghil) make-ghil-quote))
- (try-inline (@ (language scheme inline) try-inline)))
- (case-lambda
- ,@(let lp ((in clauses) (out '()))
- (if (null? in)
- (reverse (cons '(else #f) out))
- (lp (cddr in)
- (cons `(,(car in)
- ,(consequent (cadr in))) out)))))))))
-
-(define (try-inline head-value args)
- (and=> (assq-ref *inline-table* head-value)
- (lambda (proc) (apply proc args))))
-
-
-(define (try-inline-with-env env loc exp)
- (let ((sym (car exp)))
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((mod (current-module)))
- (and (not (assoc-ref table (cons (module-name mod) sym)))
- (module-bound? mod sym)
- (try-inline (module-ref mod sym) (cdr exp)))))
- ((<ghil-env> parent table variables)
- (and (not (assq-ref table sym))
- (loop parent)))))))
-
-(define-inline eq? (x y)
- (eq? x y))
-
-(define-inline eqv? (x y)
- (eqv? x y))
-
-(define-inline equal? (x y)
- (equal? x y))
-
-(define-inline = (x y)
- (ee? x y))
-
-(define-inline < (x y)
- (lt? x y))
-
-(define-inline > (x y)
- (gt? x y))
-
-(define-inline <= (x y)
- (le? x y))
-
-(define-inline >= (x y)
- (ge? x y))
-
-(define-inline zero? (x)
- (ee? x 0))
-
-(define-inline +
- () 0
- (x) x
- (x y) (add x y)
- (x y . rest) (add x (+ y . rest)))
-
-(define-inline *
- () 1
- (x) x
- (x y) (mul x y)
- (x y . rest) (mul x (* y . rest)))
-
-(define-inline -
- (x) (sub 0 x)
- (x y) (sub x y)
- (x y . rest) (sub x (+ y . rest)))
-
-(define-inline 1-
- (x) (sub x 1))
-
-(define-inline /
- (x) (div 1 x)
- (x y) (div x y)
- (x y . rest) (div x (* y . rest)))
-
-(define-inline quotient (x y)
- (quo x y))
-
-(define-inline remainder (x y)
- (rem x y))
-
-(define-inline modulo (x y)
- (mod x y))
-
-(define-inline not (x)
- (not x))
-
-(define-inline pair? (x)
- (pair? x))
-
-(define-inline cons (x y)
- (cons x y))
-
-(define-inline car (x) (car x))
-(define-inline cdr (x) (cdr x))
-
-(define-inline set-car! (x y) (set-car! x y))
-(define-inline set-cdr! (x y) (set-cdr! x y))
-
-(define-inline caar (x) (car (car x)))
-(define-inline cadr (x) (car (cdr x)))
-(define-inline cdar (x) (cdr (car x)))
-(define-inline cddr (x) (cdr (cdr x)))
-(define-inline caaar (x) (car (car (car x))))
-(define-inline caadr (x) (car (car (cdr x))))
-(define-inline cadar (x) (car (cdr (car x))))
-(define-inline caddr (x) (car (cdr (cdr x))))
-(define-inline cdaar (x) (cdr (car (car x))))
-(define-inline cdadr (x) (cdr (car (cdr x))))
-(define-inline cddar (x) (cdr (cdr (car x))))
-(define-inline cdddr (x) (cdr (cdr (cdr x))))
-(define-inline caaaar (x) (car (car (car (car x)))))
-(define-inline caaadr (x) (car (car (car (cdr x)))))
-(define-inline caadar (x) (car (car (cdr (car x)))))
-(define-inline caaddr (x) (car (car (cdr (cdr x)))))
-(define-inline cadaar (x) (car (cdr (car (car x)))))
-(define-inline cadadr (x) (car (cdr (car (cdr x)))))
-(define-inline caddar (x) (car (cdr (cdr (car x)))))
-(define-inline cadddr (x) (car (cdr (cdr (cdr x)))))
-(define-inline cdaaar (x) (cdr (car (car (car x)))))
-(define-inline cdaadr (x) (cdr (car (car (cdr x)))))
-(define-inline cdadar (x) (cdr (car (cdr (car x)))))
-(define-inline cdaddr (x) (cdr (car (cdr (cdr x)))))
-(define-inline cddaar (x) (cdr (cdr (car (car x)))))
-(define-inline cddadr (x) (cdr (cdr (car (cdr x)))))
-(define-inline cdddar (x) (cdr (cdr (cdr (car x)))))
-(define-inline cddddr (x) (cdr (cdr (cdr (cdr x)))))
-
-(define-inline null? (x)
- (null? x))
-
-(define-inline list? (x)
- (list? x))
-
-(define-inline cons*
- (x) x
- (x y) (cons x y)
- (x y . rest) (cons x (cons* y . rest)))
-
-(define-inline acons
- (x y z) (cons (cons x y) z))
;;; Code:
(define-module (language scheme spec)
+ #:use-module (system base compile)
#:use-module (system base language)
#:use-module (language scheme compile-tree-il)
#:use-module (language scheme decompile-tree-il)
(define-language scheme
#:title "Guile Scheme"
#:version "0.5"
- #:reader read
+ #:reader (lambda (port env)
+ ;; Use the binding of current-reader from the environment.
+ ;; FIXME: Handle `read-options' as well?
+ ((or (and=> (and=> (module-variable env 'current-reader)
+ variable-ref)
+ fluid-ref)
+ read)
+ port))
+
#:compilers `((tree-il . ,compile-tree-il))
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
- )
+ #:make-default-environment
+ (lambda ()
+ ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
+ ;; `fluid-set!', etc. don't have any effect in the current environment.
+ (let ((m (make-fresh-user-module)))
+ ;; Provide a separate `current-reader' fluid so that
+ ;; compile-time changes to `current-reader' are
+ ;; limited to the current compilation unit.
+ (module-define! m 'current-reader (make-fluid))
+ m)))
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
<application> application? make-application application-src application-proc application-args
<sequence> sequence? make-sequence sequence-src sequence-exps
- <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
+ <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
+ <lambda-case> lambda-case? make-lambda-case lambda-case-src
+ lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
+ lambda-case-inits lambda-case-vars
+ lambda-case-body lambda-case-else
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
- <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
+ <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
parse-tree-il
unparse-tree-il
(<conditional> test then else)
(<application> proc args)
(<sequence> exps)
- (<lambda> names vars meta body)
+ (<lambda> meta body)
+ (<lambda-case> req opt rest kw inits vars body else)
(<let> names vars vals body)
(<letrec> names vars vals body)
(<fix> names vars vals body)
- (<let-values> names vars exp body))
+ (<let-values> exp body))
\f
((define ,name ,exp) (guard (symbol? name))
(make-toplevel-define loc name (retrans exp)))
- ((lambda ,names ,vars ,exp)
- (make-lambda loc names vars '() (retrans exp)))
+ ((lambda ,meta ,body)
+ (make-lambda loc meta (retrans body)))
- ((lambda ,names ,vars ,meta ,exp)
- (make-lambda loc names vars meta (retrans exp)))
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,else)
+ (make-lambda-case loc req opt rest kw
+ (map retrans inits) vars
+ (retrans body)
+ (and=> else retrans)))
+
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body))
+ (make-lambda-case loc req opt rest kw
+ (map retrans inits) vars
+ (retrans body)
+ #f))
((const ,exp)
(make-const loc exp))
((fix ,names ,vars ,vals ,body)
(make-fix loc names vars (map retrans vals) (retrans body)))
- ((let-values ,names ,vars ,exp ,body)
- (make-let-values loc names vars (retrans exp) (retrans body)))
+ ((let-values ,exp ,body)
+ (make-let-values loc (retrans exp) (retrans body)))
(else
(error "unrecognized tree-il" exp)))))
((<toplevel-define> name exp)
`(define ,name ,(unparse-tree-il exp)))
- ((<lambda> names vars meta body)
- `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
+ ((<lambda> meta body)
+ `(lambda ,meta ,(unparse-tree-il body)))
+
+ ((<lambda-case> req opt rest kw inits vars body else)
+ `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars)
+ ,(unparse-tree-il body))
+ . ,(if else (list (unparse-tree-il else)) '())))
((<const> exp)
`(const ,exp))
((<fix> names vars vals body)
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<let-values> names vars exp body)
- `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
+ ((<let-values> exp body)
+ `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
(define (tree-il->scheme e)
(record-case e
((<primitive-ref> name)
name)
- ((<lexical-ref> name gensym)
+ ((<lexical-ref> gensym)
gensym)
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> gensym exp)
`(set! ,gensym ,(tree-il->scheme exp)))
((<module-ref> mod name public?)
((<toplevel-define> name exp)
`(define ,name ,(tree-il->scheme exp)))
- ((<lambda> vars meta body)
- `(lambda ,vars
- ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
- ,(tree-il->scheme body)))
+ ((<lambda> meta body)
+ ;; fixme: put in docstring
+ (if (and (lambda-case? body)
+ (not (lambda-case-else body)))
+ `(lambda ,@(car (tree-il->scheme body)))
+ `(case-lambda ,@(tree-il->scheme body))))
+
+ ((<lambda-case> req opt rest kw inits vars body else)
+ ;; FIXME! use parse-lambda-case?
+ `((,(if rest (apply cons* vars) vars)
+ ,(tree-il->scheme body))
+ ,@(if else (tree-il->scheme else) '())))
((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp)))
;; not a typo, we really do translate back to letrec
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
- ((<let-values> vars exp body)
+ ((<let-values> exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
- (lambda ,vars ,(tree-il->scheme body))))))
+ ,(tree-il->scheme (make-lambda #f '() body))))))
\f
(define (tree-il-fold leaf down up seed tree)
(up tree (loop exps (down tree result))))
((<lambda> body)
(up tree (loop body (down tree result))))
+ ((<lambda-case> inits body else)
+ (up tree (if else
+ (loop else
+ (loop body (loop inits (down tree result))))
+ (loop body (loop inits (down tree result))))))
((<let> vals body)
(up tree (loop body
(loop vals
(fold-values foldts exps seed ...))
((<lambda> body)
(foldts body seed ...))
+ ((<lambda-case> inits body else)
+ (let-values (((seed ...) (fold-values foldts inits seed ...)))
+ (if else
+ (let-values (((seed ...) (foldts body seed ...)))
+ (foldts else seed ...))
+ (foldts body seed ...))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp)))
- ((<lambda> vars meta body)
+ ((<lambda> body)
(set! (lambda-body x) (lp body)))
+ ((<lambda-case> inits body else)
+ (set! inits (map lp inits))
+ (set! (lambda-case-body x) (lp body))
+ (if else
+ (set! (lambda-case-else x) (lp else))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
- ((<let-values> vars exp body)
+ ((<let-values> exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
(set! (conditional-then x) (lp then))
(set! (conditional-else x) (lp else)))
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> exp)
(set! (lexical-set-exp x) (lp exp)))
- ((<module-set> mod name public? exp)
+ ((<module-set> exp)
(set! (module-set-exp x) (lp exp)))
- ((<toplevel-set> name exp)
+ ((<toplevel-set> exp)
(set! (toplevel-set-exp x) (lp exp)))
- ((<toplevel-define> name exp)
+ ((<toplevel-define> exp)
(set! (toplevel-define-exp x) (lp exp)))
- ((<lambda> vars meta body)
+ ((<lambda> body)
(set! (lambda-body x) (lp body)))
+ ((<lambda-case> inits body else)
+ (set! inits (map lp inits))
+ (set! (lambda-case-body x) (lp body))
+ (if else (set! (lambda-case-else x) (lp else))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
- ((<let> vars vals body)
+ ((<let> vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
- ((<letrec> vars vals body)
+ ((<letrec> vals body)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
- ((<fix> vars vals body)
+ ((<fix> vals body)
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
- ((<let-values> vars exp body)
+ ((<let-values> exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
#:use-module (srfi srfi-9)
#:use-module (system base syntax)
#:use-module (system base message)
+ #:use-module (system vm program)
#:use-module (language tree-il)
+ #:use-module (system base pmatch)
#:export (analyze-lexicals
- report-unused-variables))
+ analyze-tree
+ unused-variable-analysis
+ unbound-variable-analysis
+ arity-analysis))
;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
;; translated into labels, and information on what free variables to
;; capture from its lexical parent procedure.
;;
+;; In addition, we have a conflation: while we're traversing the code,
+;; recording information to pass to the compiler, we take the
+;; opportunity to generate labels for each lambda-case clause, so that
+;; generated code can skip argument checks at runtime if they match at
+;; compile-time.
+;;
;; That is:
;;
;; sym -> {lambda -> address}
-;; lambda -> (nlocs labels . free-locs)
+;; lambda -> (labels . free-locs)
+;; lambda-case -> (gensym . nlocs)
;;
;; address ::= (local? boxed? . index)
-;; labels ::= ((sym . lambda-vars) ...)
+;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
;; refcounts: sym -> count
;; allows us to detect the or-expansion in O(1) time
(define refcounts (make-hash-table))
- ;; labels: sym -> lambda-vars
+ ;; labels: sym -> lambda
;; for determining if fixed-point procedures can be rendered as
- ;; labels. lambda-vars may be an improper list.
+ ;; labels.
(define labels (make-hash-table))
;; returns variables referenced in expr
((<conditional> test then else)
(lset-union eq? (step test) (step-tail then) (step-tail else)))
- ((<lexical-ref> name gensym)
+ ((<lexical-ref> gensym)
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(if (not (and tail-call-args
(memq gensym labels-in-proc)
- (let ((args (hashq-ref labels gensym)))
- (and (list? args)
- (= (length args) (length tail-call-args))))))
+ (let ((p (hashq-ref labels gensym)))
+ (and p
+ (let lp ((c (lambda-body p)))
+ (and c (lambda-case? c)
+ (or
+ ;; for now prohibit optional &
+ ;; keyword arguments; can relax this
+ ;; restriction later
+ (and (= (length (lambda-case-req c))
+ (length tail-call-args))
+ (not (lambda-case-opt c))
+ (not (lambda-case-kw c))
+ (not (lambda-case-rest c)))
+ (lp (lambda-case-else c)))))))))
(hashq-set! labels gensym #f))
(list gensym))
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> gensym exp)
(hashq-set! assigned gensym #t)
(hashq-set! labels gensym #f)
(lset-adjoin eq? (step exp) gensym))
- ((<module-set> mod name public? exp)
+ ((<module-set> exp)
(step exp))
- ((<toplevel-set> name exp)
+ ((<toplevel-set> exp)
(step exp))
- ((<toplevel-define> name exp)
+ ((<toplevel-define> exp)
(step exp))
((<sequence> exps)
(else
(lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
- ((<lambda> vars meta body)
- (let ((locally-bound (let rev* ((vars vars) (out '()))
- (cond ((null? vars) out)
- ((pair? vars) (rev* (cdr vars)
- (cons (car vars) out)))
- (else (cons vars out))))))
- (hashq-set! bound-vars x locally-bound)
- (let* ((referenced (recur body x))
- (free (lset-difference eq? referenced locally-bound))
- (all-bound (reverse! (hashq-ref bound-vars x))))
- (hashq-set! bound-vars x all-bound)
- (hashq-set! free-vars x free)
- free)))
+ ((<lambda> body)
+ ;; order is important here
+ (hashq-set! bound-vars x '())
+ (let ((free (recur body x)))
+ (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
+ (hashq-set! free-vars x free)
+ free))
+
+ ((<lambda-case> opt kw inits vars body else)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ (lset-union
+ eq?
+ (lset-difference eq?
+ (lset-union eq?
+ (apply lset-union eq? (map step inits))
+ (step-tail body))
+ vars)
+ (if else (step-tail else) '())))
((<let> vars vals body)
(hashq-set! bound-vars proc
((<fix> vars vals body)
;; Try to allocate these procedures as labels.
- (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val)))
+ (for-each (lambda (sym val) (hashq-set! labels sym val))
vars vals)
(hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc)))
;; prevent label allocation.)
(lambda (x)
(record-case x
- ((<lambda> (lvars vars) body)
- (let ((locally-bound
- (let rev* ((lvars lvars) (out '()))
- (cond ((null? lvars) out)
- ((pair? lvars) (rev* (cdr lvars)
- (cons (car lvars) out)))
- (else (cons lvars out))))))
- (hashq-set! bound-vars x locally-bound)
- ;; recur/labels, the difference from the closure case
- (let* ((referenced (recur/labels body x vars))
- (free (lset-difference eq? referenced locally-bound))
- (all-bound (reverse! (hashq-ref bound-vars x))))
- (hashq-set! bound-vars x all-bound)
- (hashq-set! free-vars x free)
- free)))))
+ ((<lambda> body)
+ ;; just like the closure case, except here we use
+ ;; recur/labels instead of recur
+ (hashq-set! bound-vars x '())
+ (let ((free (recur/labels body x vars)))
+ (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
+ (hashq-set! free-vars x free)
+ free))))
vals))
(vars-with-refs (map cons vars var-refs))
(body-refs (recur/labels body proc vars)))
(apply lset-union eq? body-refs var-refs)
vars)))
- ((<let-values> vars exp body)
- (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
- (if (pair? in)
- (lp (cons (car in) out) (cdr in))
- (if (null? in) out (cons in out))))))
- (hashq-set! bound-vars proc bound)
- (lset-difference eq?
- (lset-union eq? (step exp) (step-tail body))
- bound)))
+ ((<let-values> exp body)
+ (lset-union eq? (step exp) (step body)))
(else '())))
((<conditional> test then else)
(max (recur test) (recur then) (recur else)))
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> exp)
(recur exp))
- ((<module-set> mod name public? exp)
+ ((<module-set> exp)
(recur exp))
- ((<toplevel-set> name exp)
+ ((<toplevel-set> exp)
(recur exp))
- ((<toplevel-define> name exp)
+ ((<toplevel-define> exp)
(recur exp))
((<sequence> exps)
(apply max (map recur exps)))
- ((<lambda> vars meta body)
+ ((<lambda> body)
;; allocate closure vars in order
(let lp ((c (hashq-ref free-vars x)) (n 0))
(if (pair? c)
`(#f ,(hashq-ref assigned (car c)) . ,n))
(lp (cdr c) (1+ n)))))
- (let ((nlocs
- (let lp ((vars vars) (n 0))
- (if (not (null? vars))
- ;; allocate args
- (let ((v (if (pair? vars) (car vars) vars)))
- (hashq-set! allocation v
- (make-hashq
- x `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
- ;; allocate body, return number of additional locals
- (- (allocate! body x n) n))))
+ (let ((nlocs (allocate! body x 0))
(free-addresses
(map (lambda (v)
(hashq-ref (hashq-ref allocation v) proc))
(cons sym (hashq-ref labels sym)))
(hashq-ref bound-vars x)))))
;; set procedure allocations
- (hashq-set! allocation x (cons* nlocs labels free-addresses)))
+ (hashq-set! allocation x (cons labels free-addresses)))
n)
+ ((<lambda-case> opt kw inits vars body else)
+ (max
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nlocs (apply
+ max
+ (allocate! body proc n)
+ ;; inits not logically at the end, but they
+ ;; are the list...
+ (map (lambda (x) (allocate! x body n)) inits))))
+ ;; label and nlocs for the case
+ (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
+ nlocs)
+ (begin
+ (hashq-set! allocation (car vars)
+ (make-hashq
+ proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
+ (lp (cdr vars) (1+ n)))))
+ (if else (allocate! else proc n) n)))
+
((<let> vars vals body)
(let ((nmax (apply max (map recur vals))))
(cond
((null? vars)
(max nmax (allocate! body proc n)))
((hashq-ref labels (car vars))
- ;; allocate label bindings & body inline to proc
+ ;; allocate lambda body inline to proc
(lp (cdr vars)
(cdr vals)
(record-case (car vals)
- ((<lambda> vars body)
- (let lp ((vars vars) (n n))
- (if (not (null? vars))
- ;; allocate bindings
- (let ((v (if (pair? vars) (car vars) vars)))
- (hashq-set!
- allocation v
- (make-hashq
- proc `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
- ;; allocate body
- (max nmax (allocate! body proc n))))))))
+ ((<lambda> body)
+ (max nmax (allocate! body proc n))))))
(else
;; allocate closure
(lp (cdr vars)
(hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
(lp (cdr in) (1+ n))))))))
- ((<let-values> vars exp body)
- (let ((nmax (recur exp)))
- (let lp ((vars vars) (n n))
- (cond
- ((null? vars)
- (max nmax (allocate! body proc n)))
- ((not (pair? vars))
- (hashq-set! allocation vars
- (make-hashq proc
- `(#t ,(hashq-ref assigned vars) . ,n)))
- ;; the 1+ for this var
- (max nmax (allocate! body proc (1+ n))))
- (else
- (let ((v (car vars)))
- (hashq-set!
- allocation v
- (make-hashq proc
- `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n))))))))
+ ((<let-values> exp body)
+ (max (recur exp) (recur body)))
(else n)))
allocation)
\f
+;;;
+;;; Tree analyses for warnings.
+;;;
+
+(define-record-type <tree-analysis>
+ (make-tree-analysis leaf down up post init)
+ tree-analysis?
+ (leaf tree-analysis-leaf) ;; (lambda (x result env) ...)
+ (down tree-analysis-down) ;; (lambda (x result env) ...)
+ (up tree-analysis-up) ;; (lambda (x result env) ...)
+ (post tree-analysis-post) ;; (lambda (result env) ...)
+ (init tree-analysis-init)) ;; arbitrary value
+
+(define (analyze-tree analyses tree env)
+ "Run all tree analyses listed in ANALYSES on TREE for ENV, using
+`tree-il-fold'. Return TREE."
+ (define (traverse proc)
+ (lambda (x results)
+ (map (lambda (analysis result)
+ ((proc analysis) x result env))
+ analyses
+ results)))
+
+ (let ((results
+ (tree-il-fold (traverse tree-analysis-leaf)
+ (traverse tree-analysis-down)
+ (traverse tree-analysis-up)
+ (map tree-analysis-init analyses)
+ tree)))
+
+ (for-each (lambda (analysis result)
+ ((tree-analysis-post analysis) result env))
+ analyses
+ results))
+
+ tree)
+
+\f
;;;
;;; Unused variable analysis.
;;;
(refs binding-info-refs) ;; (GENSYM ...)
(locs binding-info-locs)) ;; (LOCATION ...)
-(define (report-unused-variables tree)
- "Report about unused variables in TREE. Return TREE."
+(define unused-variable-analysis
+ ;; Report unused variables in the given tree.
+ (make-tree-analysis
+ (lambda (x info env)
+ ;; X is a leaf: extend INFO's refs accordingly.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info)))
+ (record-case x
+ ((<lexical-ref> gensym)
+ (make-binding-info vars (cons gensym refs) locs))
+ (else info))))
+
+ (lambda (x info env)
+ ;; Going down into X: extend INFO's variable list
+ ;; accordingly.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info))
+ (src (tree-il-src x)))
+ (define (extend inner-vars inner-names)
+ (append (map (lambda (var name)
+ (list var name src))
+ inner-vars
+ inner-names)
+ vars))
+ (record-case x
+ ((<lexical-set> gensym)
+ (make-binding-info vars (cons gensym refs)
+ (cons src locs)))
+ ((<lambda-case> req opt inits rest kw vars)
+ (let ((names `(,@req
+ ,@(or opt '())
+ ,@(if rest (list rest) '())
+ ,@(if kw (map cadr (cdr kw)) '()))))
+ (make-binding-info (extend vars names) refs
+ (cons src locs))))
+ ((<let> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<letrec> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<fix> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ (else info))))
+
+ (lambda (x info env)
+ ;; Leaving X's scope: shrink INFO's variable list
+ ;; accordingly and reported unused nested variables.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info)))
+ (define (shrink inner-vars refs)
+ (for-each (lambda (var)
+ (let ((gensym (car var)))
+ ;; Don't report lambda parameters as
+ ;; unused.
+ (if (and (not (memq gensym refs))
+ (not (and (lambda-case? x)
+ (memq gensym
+ inner-vars))))
+ (let ((name (cadr var))
+ ;; We can get approximate
+ ;; source location by going up
+ ;; the LOCS location stack.
+ (loc (or (caddr var)
+ (find pair? locs))))
+ (warning 'unused-variable loc name)))))
+ (filter (lambda (var)
+ (memq (car var) inner-vars))
+ vars))
+ (fold alist-delete vars inner-vars))
+
+ ;; For simplicity, we leave REFS untouched, i.e., with
+ ;; names of variables that are now going out of scope.
+ ;; It doesn't hurt as these are unique names, it just
+ ;; makes REFS unnecessarily fat.
+ (record-case x
+ ((<lambda-case> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<let> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<letrec> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<fix> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ (else info))))
+
+ (lambda (result env) #t)
+ (make-binding-info '() '() '())))
+
+\f
+;;;
+;;; Unbound variable analysis.
+;;;
+
+;; <toplevel-info> records are used during tree traversal in search of
+;; possibly unbound variable. They contain a list of references to
+;; potentially unbound top-level variables, a list of the top-level defines
+;; that have been encountered, and a "location stack" (see above).
+(define-record-type <toplevel-info>
+ (make-toplevel-info refs defs locs)
+ toplevel-info?
+ (refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...)
+ (defs toplevel-info-defs) ;; (VARIABLE-NAME ...)
+ (locs toplevel-info-locs)) ;; (LOCATION ...)
+
+(define (goops-toplevel-definition proc args env)
+ ;; If application of PROC to ARGS is a GOOPS top-level definition, return
+ ;; the name of the variable being defined; otherwise return #f. This
+ ;; assumes knowledge of the current implementation of `define-class' et al.
+ (define (toplevel-define-arg args)
+ (and (pair? args) (pair? (cdr args)) (null? (cddr args))
+ (record-case (car args)
+ ((<const> exp)
+ (and (symbol? exp) exp))
+ (else #f))))
- (define (dotless-list lst)
- ;; If LST is a dotted list, return a proper list equal to LST except that
- ;; the very last element is a pair; otherwise return LST.
- (let loop ((lst lst)
+ (record-case proc
+ ((<module-ref> mod public? name)
+ (and (equal? mod '(oop goops))
+ (not public?)
+ (eq? name 'toplevel-define!)
+ (toplevel-define-arg args)))
+ ((<toplevel-ref> name)
+ ;; This may be the result of expanding one of the GOOPS macros within
+ ;; `oop/goops.scm'.
+ (and (eq? name 'toplevel-define!)
+ (eq? env (resolve-module '(oop goops)))
+ (toplevel-define-arg args)))
+ (else #f)))
+
+(define unbound-variable-analysis
+ ;; Report possibly unbound variables in the given tree.
+ (make-tree-analysis
+ (lambda (x info env)
+ ;; X is a leaf: extend INFO's refs accordingly.
+ (let ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (locs (toplevel-info-locs info)))
+ (define (bound? name)
+ (or (and (module? env)
+ (module-variable env name))
+ (memq name defs)))
+
+ (record-case x
+ ((<toplevel-ref> name src)
+ (if (bound? name)
+ info
+ (let ((src (or src (find pair? locs))))
+ (make-toplevel-info (alist-cons name src refs)
+ defs
+ locs))))
+ (else info))))
+
+ (lambda (x info env)
+ ;; Going down into X.
+ (let* ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (src (tree-il-src x))
+ (locs (cons src (toplevel-info-locs info))))
+ (define (bound? name)
+ (or (and (module? env)
+ (module-variable env name))
+ (memq name defs)))
+
+ (record-case x
+ ((<toplevel-set> name src)
+ (if (bound? name)
+ (make-toplevel-info refs defs locs)
+ (let ((src (find pair? locs)))
+ (make-toplevel-info (alist-cons name src refs)
+ defs
+ locs))))
+ ((<toplevel-define> name)
+ (make-toplevel-info (alist-delete name refs eq?)
+ (cons name defs)
+ locs))
+
+ ((<application> proc args)
+ ;; Check for a dynamic top-level definition, as is
+ ;; done by code expanded from GOOPS macros.
+ (let ((name (goops-toplevel-definition proc args
+ env)))
+ (if (symbol? name)
+ (make-toplevel-info (alist-delete name refs
+ eq?)
+ (cons name defs)
+ locs)
+ (make-toplevel-info refs defs locs))))
+ (else
+ (make-toplevel-info refs defs locs)))))
+
+ (lambda (x info env)
+ ;; Leaving X's scope.
+ (let ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (locs (toplevel-info-locs info)))
+ (make-toplevel-info refs defs (cdr locs))))
+
+ (lambda (toplevel env)
+ ;; Post-process the result.
+ (for-each (lambda (name+loc)
+ (let ((name (car name+loc))
+ (loc (cdr name+loc)))
+ (warning 'unbound-variable loc name)))
+ (reverse (toplevel-info-refs toplevel))))
+
+ (make-toplevel-info '() '() '())))
+
+\f
+;;;
+;;; Arity analysis.
+;;;
+
+;; <arity-info> records contain information about lexical definitions of
+;; procedures currently in scope, top-level procedure definitions that have
+;; been encountered, and calls to top-level procedures that have been
+;; encountered.
+(define-record-type <arity-info>
+ (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
+ arity-info?
+ (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
+ (lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
+ (toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
+
+(define (validate-arity proc application lexical?)
+ ;; Validate the argument count of APPLICATION, a tree-il application of
+ ;; PROC, emitting a warning in case of argument count mismatch.
+
+ (define (filter-keyword-args keywords allow-other-keys? args)
+ ;; Filter keyword arguments from ARGS and return the resulting list.
+ ;; KEYWORDS is the list of allowed keywords, and ALLOW-OTHER-KEYS?
+ ;; specified whethere keywords not listed in KEYWORDS are allowed.
+ (let loop ((args args)
(result '()))
- (cond ((null? lst)
- (reverse result))
- ((pair? lst)
- (loop (cdr lst) (cons (car lst) result)))
- (else
- (loop '() (cons lst result))))))
-
- (tree-il-fold (lambda (x info)
- ;; X is a leaf: extend INFO's refs accordingly.
- (let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info)))
- (record-case x
- ((<lexical-ref> gensym)
- (make-binding-info vars (cons gensym refs) locs))
- (else info))))
-
- (lambda (x info)
- ;; Going down into X: extend INFO's variable list
- ;; accordingly.
- (let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info))
- (src (tree-il-src x)))
- (define (extend inner-vars inner-names)
- (append (map (lambda (var name)
- (list var name src))
- inner-vars
- inner-names)
- vars))
- (record-case x
- ((<lexical-set> gensym)
- (make-binding-info vars (cons gensym refs)
- (cons src locs)))
- ((<lambda> vars names)
- (let ((vars (dotless-list vars))
- (names (dotless-list names)))
- (make-binding-info (extend vars names) refs
- (cons src locs))))
- ((<let> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
- ((<letrec> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
- ((<fix> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
- ((<let-values> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
- (else info))))
-
- (lambda (x info)
- ;; Leaving X's scope: shrink INFO's variable list
- ;; accordingly and reported unused nested variables.
- (let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info)))
- (define (shrink inner-vars refs)
- (for-each (lambda (var)
- (let ((gensym (car var)))
- ;; Don't report lambda parameters as
- ;; unused.
- (if (and (not (memq gensym refs))
- (not (and (lambda? x)
- (memq gensym
- inner-vars))))
- (let ((name (cadr var))
- ;; We can get approximate
- ;; source location by going up
- ;; the LOCS location stack.
- (loc (or (caddr var)
- (find pair? locs))))
- (warning 'unused-variable loc name)))))
- (filter (lambda (var)
- (memq (car var) inner-vars))
- vars))
- (fold alist-delete vars inner-vars))
-
- ;; For simplicity, we leave REFS untouched, i.e., with
- ;; names of variables that are now going out of scope.
- ;; It doesn't hurt as these are unique names, it just
- ;; makes REFS unnecessarily fat.
- (record-case x
- ((<lambda> vars)
- (let ((vars (dotless-list vars)))
- (make-binding-info (shrink vars refs) refs
- (cdr locs))))
- ((<let> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
- ((<letrec> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
- ((<fix> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
- ((<let-values> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
- (else info))))
- (make-binding-info '() '() '())
- tree)
- tree)
+ (if (null? args)
+ (reverse result)
+ (let ((arg (car args)))
+ (if (and (const? arg)
+ (or (memq (const-exp arg) keywords)
+ (and allow-other-keys?
+ (keyword? (const-exp arg)))))
+ (loop (if (pair? (cdr args))
+ (cddr args)
+ '())
+ result)
+ (loop (cdr args)
+ (cons arg result)))))))
+
+ (define (arities proc)
+ ;; Return the arities of PROC, which can be either a tree-il or a
+ ;; procedure.
+ (define (len x)
+ (or (and (or (null? x) (pair? x))
+ (length x))
+ 0))
+ (cond ((program? proc)
+ (values (program-name proc)
+ (map (lambda (a)
+ (list (arity:nreq a) (arity:nopt a) (arity:rest? a)
+ (map car (arity:kw a))
+ (arity:allow-other-keys? a)))
+ (program-arities proc))))
+ ((procedure? proc)
+ (let ((arity (procedure-property proc 'arity)))
+ (values (procedure-name proc)
+ (list (list (car arity) (cadr arity) (caddr arity)
+ #f #f)))))
+ (else
+ (let loop ((name #f)
+ (proc proc)
+ (arities '()))
+ (if (not proc)
+ (values name (reverse arities))
+ (record-case proc
+ ((<lambda-case> req opt rest kw else)
+ (loop name else
+ (cons (list (len req) (len opt) rest
+ (and (pair? kw) (map car (cdr kw)))
+ (and (pair? kw) (car kw)))
+ arities)))
+ ((<lambda> meta body)
+ (loop (assoc-ref meta 'name) body arities))
+ (else
+ (values #f #f))))))))
+
+ (let ((args (application-args application))
+ (src (tree-il-src application)))
+ (call-with-values (lambda () (arities proc))
+ (lambda (name arities)
+ (define matches?
+ (find (lambda (arity)
+ (pmatch arity
+ ((,req ,opt ,rest? ,kw ,aok?)
+ (let ((args (if (pair? kw)
+ (filter-keyword-args kw aok? args)
+ args)))
+ (if (and req opt)
+ (let ((count (length args)))
+ (and (>= count req)
+ (or rest?
+ (<= count (+ req opt)))))
+ #t)))
+ (else #t)))
+ arities))
+
+ (if (not matches?)
+ (warning 'arity-mismatch src
+ (or name (with-output-to-string (lambda () (write proc))))
+ lexical?)))))
+ #t)
+
+(define arity-analysis
+ ;; Report arity mismatches in the given tree.
+ (make-tree-analysis
+ (lambda (x info env)
+ ;; X is a leaf.
+ info)
+ (lambda (x info env)
+ ;; Down into X.
+ (define (extend lexical-name val info)
+ ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
+ (let ((toplevel-calls (toplevel-procedure-calls info))
+ (lexical-lambdas (lexical-lambdas info))
+ (toplevel-lambdas (toplevel-lambdas info)))
+ (record-case val
+ ((<lambda> body)
+ (make-arity-info toplevel-calls
+ (alist-cons lexical-name val
+ lexical-lambdas)
+ toplevel-lambdas))
+ ((<lexical-ref> gensym)
+ ;; lexical alias
+ (let ((val* (assq gensym lexical-lambdas)))
+ (if (pair? val*)
+ (extend lexical-name (cdr val*) info)
+ info)))
+ ((<toplevel-ref> name)
+ ;; top-level alias
+ (make-arity-info toplevel-calls
+ (alist-cons lexical-name val
+ lexical-lambdas)
+ toplevel-lambdas))
+ (else info))))
+
+ (let ((toplevel-calls (toplevel-procedure-calls info))
+ (lexical-lambdas (lexical-lambdas info))
+ (toplevel-lambdas (toplevel-lambdas info)))
+
+ (record-case x
+ ((<toplevel-define> name exp)
+ (record-case exp
+ ((<lambda> body)
+ (make-arity-info toplevel-calls
+ lexical-lambdas
+ (alist-cons name exp toplevel-lambdas)))
+ ((<toplevel-ref> name)
+ ;; alias for another toplevel
+ (let ((proc (assq name toplevel-lambdas)))
+ (make-arity-info toplevel-calls
+ lexical-lambdas
+ (alist-cons (toplevel-define-name x)
+ (if (pair? proc)
+ (cdr proc)
+ exp)
+ toplevel-lambdas))))
+ (else info)))
+ ((<let> vars vals)
+ (fold extend info vars vals))
+ ((<letrec> vars vals)
+ (fold extend info vars vals))
+ ((<fix> vars vals)
+ (fold extend info vars vals))
+
+ ((<application> proc args src)
+ (record-case proc
+ ((<lambda> body)
+ (validate-arity proc x #t)
+ info)
+ ((<toplevel-ref> name)
+ (make-arity-info (alist-cons name x toplevel-calls)
+ lexical-lambdas
+ toplevel-lambdas))
+ ((<lexical-ref> gensym)
+ (let ((proc (assq gensym lexical-lambdas)))
+ (if (pair? proc)
+ (record-case (cdr proc)
+ ((<toplevel-ref> name)
+ ;; alias to toplevel
+ (make-arity-info (alist-cons name x toplevel-calls)
+ lexical-lambdas
+ toplevel-lambdas))
+ (else
+ (validate-arity (cdr proc) x #t)
+ info))
+
+ ;; If GENSYM wasn't found, it may be because it's an
+ ;; argument of the procedure being compiled.
+ info)))
+ (else info)))
+ (else info))))
+
+ (lambda (x info env)
+ ;; Up from X.
+ (define (shrink name val info)
+ ;; Remove NAME from the lexical-lambdas of INFO.
+ (let ((toplevel-calls (toplevel-procedure-calls info))
+ (lexical-lambdas (lexical-lambdas info))
+ (toplevel-lambdas (toplevel-lambdas info)))
+ (make-arity-info toplevel-calls
+ (alist-delete name lexical-lambdas eq?)
+ toplevel-lambdas)))
+
+ (let ((toplevel-calls (toplevel-procedure-calls info))
+ (lexical-lambdas (lexical-lambdas info))
+ (toplevel-lambdas (toplevel-lambdas info)))
+ (record-case x
+ ((<let> vars vals)
+ (fold shrink info vars vals))
+ ((<letrec> vars vals)
+ (fold shrink info vars vals))
+ ((<fix> vars vals)
+ (fold shrink info vars vals))
+
+ (else info))))
+
+ (lambda (result env)
+ ;; Post-processing: check all top-level procedure calls that have been
+ ;; encountered.
+ (let ((toplevel-calls (toplevel-procedure-calls result))
+ (toplevel-lambdas (toplevel-lambdas result)))
+ (for-each (lambda (name+application)
+ (let* ((name (car name+application))
+ (application (cdr name+application))
+ (proc
+ (or (assoc-ref toplevel-lambdas name)
+ (and (module? env)
+ (false-if-exception
+ (module-ref env name)))))
+ (proc*
+ ;; handle toplevel aliases
+ (if (toplevel-ref? proc)
+ (let ((name (toplevel-ref-name proc)))
+ (and (module? env)
+ (false-if-exception
+ (module-ref env name))))
+ proc)))
+ ;; (format #t "toplevel-call to ~A (~A) from ~A~%"
+ ;; name proc* application)
+ (if (or (lambda? proc*) (procedure? proc*))
+ (validate-arity proc* application (lambda? proc*)))))
+ toplevel-calls)))
+
+ (make-arity-info '() '() '())))
#:use-module (language tree-il)
#:use-module (language tree-il optimize)
#:use-module (language tree-il analyze)
+ #:use-module ((srfi srfi-1) #:select (filter-map))
#:export (compile-glil))
-;;; TODO:
-;;
-;; call-with-values -> mv-bind
-;; basic degenerate-case reduction
-
;; allocation:
;; sym -> {lambda -> address}
-;; lambda -> (nlocs labels . free-locs)
+;; lambda -> (labels . free-locs)
+;; lambda-case -> (gensym . nlocs)
;;
-;; address := (local? boxed? . index)
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
(define *comp-module* (make-fluid))
(define %warning-passes
- `((unused-variable . ,report-unused-variables)))
+ `((unused-variable . ,unused-variable-analysis)
+ (unbound-variable . ,unbound-variable-analysis)
+ (arity-mismatch . ,arity-analysis)))
(define (compile-glil x e opts)
(define warnings
(or (and=> (memq #:warnings opts) cadr)
'()))
- ;; Go throught the warning passes.
- (for-each (lambda (kind)
- (let ((warn (assoc-ref %warning-passes kind)))
- (and (procedure? warn)
- (warn x))))
- warnings)
+ ;; Go through the warning passes.
+ (let ((analyses (filter-map (lambda (kind)
+ (assoc-ref %warning-passes kind))
+ warnings)))
+ (analyze-tree analyses x e))
- (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+ (let* ((x (make-lambda (tree-il-src x) '()
+ (make-lambda-case #f '() #f #f #f '() '() x #f)))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
- (with-fluid* *comp-module* (or (and e (car e)) (current-module))
+ (with-fluid* *comp-module* e
(lambda ()
(values (flatten-lambda x #f allocation)
- (and e (cons (car e) (cddr e)))
+ e
e)))))
\f
((quotient . 2) . quo)
((remainder . 2) . rem)
((modulo . 2) . mod)
+ ((ash . 2) . ash)
+ ((logand . 2) . logand)
+ ((logior . 2) . logior)
+ ((logxor . 2) . logxor)
((not . 1) . not)
((pair? . 1) . pair?)
((cons . 2) . cons)
((list? . 1) . list?)
(list . list)
(vector . vector)
+ ((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set)
+ ((variable-ref . 1) . variable-ref)
+ ;; nb, *not* variable-set! -- the args are switched
+ ((variable-set . 2) . variable-set)
+
+ ;; hack for javascript
+ ((return . 1) return)
((bytevector-u8-ref . 2) . bv-u8-ref)
((bytevector-u8-set! . 3) . bv-u8-set)
ids
vars))
-;; FIXME: always emit? otherwise it's hard to pair bind with unbind
(define (emit-bindings src ids vars allocation proc emit-code)
(emit-code src (make-glil-bind
(vars->bind-list ids vars allocation proc))))
(reverse out)))
(define (flatten-lambda x self-label allocation)
- (receive (ids vars nargs nrest)
- (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
- (oids '()) (ovars '()) (n 0))
- (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
- ((pair? vars) (lp (cdr ids) (cdr vars)
- (cons (car ids) oids) (cons (car vars) ovars)
- (1+ n)))
- (else (values (reverse (cons ids oids))
- (reverse (cons vars ovars))
- (1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x)))
- (labels (cadr (hashq-ref allocation x))))
- (make-glil-program
- nargs nrest nlocs (lambda-meta x)
- (with-output-to-code
- (lambda (emit-code)
- ;; emit label for self tail calls
- (if self-label
- (emit-code #f (make-glil-label self-label)))
- ;; write bindings and source debugging info
- (if (not (null? ids))
- (emit-bindings #f ids vars allocation x emit-code))
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- ;; box args if necessary
- (for-each
- (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) x)
- ((#t #t . ,n)
- (emit-code #f (make-glil-lexical #t #f 'ref n))
- (emit-code #f (make-glil-lexical #t #t 'box n)))))
- vars)
- ;; and here, here, dear reader: we compile.
- (flatten (lambda-body x) allocation x self-label
- labels emit-code)))))))
+ (record-case x
+ ((<lambda> src meta body)
+ (make-glil-program
+ meta
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; write source info for proc
+ (if src (emit-code #f (make-glil-source src)))
+ ;; emit pre-prelude label for self tail calls in which the
+ ;; number of arguments doesn't check out at compile time
+ (if self-label
+ (emit-code #f (make-glil-label self-label)))
+ ;; compile the body, yo
+ (flatten body allocation x self-label (car (hashq-ref allocation x))
+ emit-code)))))))
(define (flatten x allocation self self-label fix-labels emit-code)
(define (emit-label label)
(maybe-emit-return))
;; FIXME: should represent sequence as exps tail
- ((<sequence> src exps)
+ ((<sequence> exps)
(let lp ((exps exps))
(if (null? (cdr exps))
(comp-tail (car exps))
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
- ;; da capo al fine
+ ;; self-call in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
- ;; self-call in tail position is a goto
- (eq? context 'tail)
- ;; make sure the arity is right
- (list? (lambda-vars self))
- (= (length args) (length (lambda-vars self))))
- ;; evaluate new values
+ (eq? context 'tail))
+ ;; first, evaluate new values, pushing them on the stack
(for-each comp-push args)
- ;; rename & goto
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t ,boxed? . ,index)
- ;; set unboxed, as the proc prelude will box if needed
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- (,x (error "what" x))))
- (reverse (lambda-vars self)))
- (emit-branch src 'br self-label))
+ (let lp ((lcase (lambda-body self)))
+ (cond
+ ((and (lambda-case? lcase)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-opt lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args) (length (lambda-case-req lcase))))
+ ;; we have a case that matches the args; rename variables
+ ;; and goto the case label
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index) ; boxed
+ ;; new box
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "what" x))))
+ (reverse (lambda-case-vars lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+ ((lambda-case? lcase)
+ ;; no match, try next case
+ (lp (lambda-case-else lcase)))
+ (else
+ ;; no cases left; shuffle args down and jump before the prelude.
+ (for-each (lambda (i)
+ (emit-code #f (make-glil-lexical #t #f 'set i)))
+ (reverse (iota (length args))))
+ (emit-branch src 'br self-label)))))
;; lambda, the ultimate goto
((and (lexical-ref? proc)
(assq (lexical-ref-gensym proc) fix-labels))
- ;; evaluate new values, assuming that analyze-lexicals did its
- ;; job, and that the arity was right
+ ;; like the self-tail-call case, though we can handle "drop"
+ ;; contexts too. first, evaluate new values, pushing them on
+ ;; the stack
(for-each comp-push args)
- ;; rename
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t #f . ,index)
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- ((#t #t . ,index)
- (emit-code #f (make-glil-lexical #t #t 'box index)))
- (,x (error "what" x))))
- (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
- ;; goto!
- (emit-branch src 'br (lexical-ref-gensym proc)))
+ ;; find the specific case, rename args, and goto the case label
+ (let lp ((lcase (lambda-body
+ (assq-ref fix-labels (lexical-ref-gensym proc)))))
+ (cond
+ ((and (lambda-case? lcase)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-opt lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args) (length (lambda-case-req lcase))))
+ ;; we have a case that matches the args; rename variables
+ ;; and goto the case label
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index) ; boxed
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "what" x))))
+ (reverse (lambda-case-vars lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+ ((lambda-case? lcase)
+ ;; no match, try next case
+ (lp (lambda-case-else lcase)))
+ (else
+ ;; no cases left. we can't really handle this currently.
+ ;; ideally we would push on a new frame, then do a "local
+ ;; call" -- which doesn't require consing up a program
+ ;; object. but for now error, as this sort of case should
+ ;; preclude label allocation.
+ (error "couldn't find matching case for label call" x)))))
(else
(if (not (eq? context 'tail))
(emit-branch #f 'br RA)
(emit-label POST)))))))))
- ((<conditional> src test then else)
+ ((<conditional> src test then (alternate else))
;; TEST
;; (br-if-not L1)
;; THEN
;; L1: ELSE
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
- (comp-push test)
- (emit-branch src 'br-if-not L1)
+ ;; need a pattern matcher
+ (record-case test
+ ((<application> proc args)
+ (record-case proc
+ ((<primitive-ref> name)
+ (let ((len (length args)))
+ (cond
+
+ ((and (eq? name 'eq?) (= len 2))
+ (comp-push (car args))
+ (comp-push (cadr args))
+ (emit-branch src 'br-if-not-eq L1))
+
+ ((and (eq? name 'null?) (= len 1))
+ (comp-push (car args))
+ (emit-branch src 'br-if-not-null L1))
+
+ ((and (eq? name 'not) (= len 1))
+ (let ((app (car args)))
+ (record-case app
+ ((<application> proc args)
+ (let ((len (length args)))
+ (record-case proc
+ ((<primitive-ref> name)
+ (cond
+
+ ((and (eq? name 'eq?) (= len 2))
+ (comp-push (car args))
+ (comp-push (cadr args))
+ (emit-branch src 'br-if-eq L1))
+
+ ((and (eq? name 'null?) (= len 1))
+ (comp-push (car args))
+ (emit-branch src 'br-if-null L1))
+
+ (else
+ (comp-push app)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push app)
+ (emit-branch src 'br-if L1)))))
+ (else
+ (comp-push app)
+ (emit-branch src 'br-if L1)))))
+
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)))))
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1))))
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)))
+
(comp-tail then)
;; if there is an RA, comp-tail will cause a jump to it -- just
;; have to clean up here if there is no RA.
(if (and (not RA) (not (eq? context 'tail)))
(emit-branch #f 'br L2))
(emit-label L1)
- (comp-tail else)
+ (comp-tail alternate)
(if (and (not RA) (not (eq? context 'tail)))
(emit-label L2))))
'ref (module-name (fluid-ref *comp-module*)) name #f))))
(maybe-emit-return))))
- ((<lexical-ref> src name gensym)
+ ((<lexical-ref> src gensym)
(case context
((push vals tail)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
(error "badness" x loc)))))
(maybe-emit-return))
- ((<lexical-set> src name gensym exp)
+ ((<lexical-set> src gensym exp)
(comp-push exp)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(maybe-emit-return))
((<lambda>)
- (let ((free-locs (cddr (hashq-ref allocation x))))
+ (let ((free-locs (cdr (hashq-ref allocation x))))
(case context
((push vals tail)
(emit-code #f (flatten-lambda x #f allocation))
(emit-code #f (make-glil-call 'make-closure 2)))))))
(maybe-emit-return))
+ ((<lambda-case> src req opt rest kw inits vars else body)
+ ;; o/~ feature on top of feature o/~
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw: (allow-other-keys? (keyword name var) ...) | #f
+ ;; vars: (sym ...)
+ ;; init: tree-il in context of vars
+ ;; vars map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (opt-names (or opt '()))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ (pmatch x
+ ((,key ,name ,var)
+ (cons key (list-index vars var)))
+ (else (error "bad kwarg" x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices))))
+ (nlocs (cdr (hashq-ref allocation x)))
+ (else-label (and else (make-label))))
+ (or (= nargs
+ (length vars)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "something went wrong"
+ req opt rest kw inits vars nreq nopt kw-indices nargs))
+ ;; the prelude, to check args & reset the stack pointer,
+ ;; allowing room for locals
+ (emit-code
+ src
+ (cond
+ (kw
+ (make-glil-kw-prelude nreq nopt rest-idx kw-indices
+ allow-other-keys? nlocs else-label))
+ ((or rest opt)
+ (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
+ (#t
+ (make-glil-std-prelude nreq nlocs else-label))))
+ ;; box args if necessary
+ (for-each
+ (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ vars)
+ ;; write bindings info
+ (if (not (null? vars))
+ (emit-bindings
+ #f
+ (let lp ((kw (if kw (cdr kw) '()))
+ (names (append (reverse opt-names) (reverse req)))
+ (vars (list-tail vars (+ nreq nopt
+ (if rest 1 0)))))
+ (pmatch kw
+ (()
+ ;; fixme: check that vars is empty
+ (reverse (if rest (cons rest names) names)))
+ (((,key ,name ,var) . ,kw)
+ (if (memq var vars)
+ (lp kw (cons name names) (delq var vars))
+ (lp kw names vars)))
+ (,kw (error "bad keywords, yo" kw))))
+ vars allocation self emit-code))
+ ;; init optional/kw args
+ (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
+ (cond
+ ((null? inits)) ; done
+ ((and rest-idx (= n rest-idx))
+ (lp inits (1+ n) (cdr vars)))
+ (#t
+ (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
+ ((#t ,boxed? . ,n*) (guard (= n* n))
+ (let ((L (make-label)))
+ (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
+ (emit-code #f (make-glil-branch 'br-if L))
+ (comp-push (car inits))
+ (emit-code #f (make-glil-lexical #t boxed? 'set n))
+ (emit-label L)
+ (lp (cdr inits) (1+ n) (cdr vars))))
+ (#t (error "what" inits))))))
+ ;; post-prelude case label for label calls
+ (emit-label (car (hashq-ref allocation x)))
+ (comp-tail body)
+ (if (not (null? vars))
+ (emit-code #f (make-glil-unbind)))
+ (if else-label
+ (begin
+ (emit-label else-label)
+ (comp-tail else)))))
+
((<let> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation self emit-code)
;; we know the vals are lambdas, we can set them to their local
;; var slots first, then capture their bindings, mutating them in
;; place.
- (let ((RA (if (eq? context 'tail) #f (make-label))))
+ (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
(for-each
(lambda (x v)
(cond
((hashq-ref allocation x)
;; allocating a closure
(emit-code #f (flatten-lambda x v allocation))
- (if (not (null? (cddr (hashq-ref allocation x))))
+ (if (not (null? (cdr (hashq-ref allocation x))))
;; Need to make-closure first, but with a temporary #f
;; free-variables vector, so we are mutating fresh
;; closures on the heap.
;; labels allocation: emit label & body, but jump over it
(let ((POST (make-label)))
(emit-branch #f 'br POST)
- (emit-label v)
- ;; we know the lambda vars are a list
- (emit-bindings #f (lambda-names x) (lambda-vars x)
- allocation self emit-code)
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- (comp-fix (lambda-body x) RA)
- (emit-code #f (make-glil-unbind))
- (emit-label POST)))))
+ (let lp ((lcase (lambda-body x)))
+ (if lcase
+ (record-case lcase
+ ((<lambda-case> src req vars body else)
+ (emit-label (car (hashq-ref allocation lcase)))
+ ;; FIXME: opt & kw args in the bindings
+ (emit-bindings #f req vars allocation self emit-code)
+ (if src
+ (emit-code #f (make-glil-source src)))
+ (comp-fix body (or RA new-RA))
+ (emit-code #f (make-glil-unbind))
+ (lp else)))
+ (emit-label POST)))))))
vals
vars)
;; Emit bindings metadata for closures
(for-each
(lambda (x v)
(let ((free-locs (if (hashq-ref allocation x)
- (cddr (hashq-ref allocation x))
+ (cdr (hashq-ref allocation x))
;; can hit this latter case for labels allocation
'())))
(if (not (null? free-locs))
vals
vars)
(comp-tail body)
- (emit-label RA)
+ (if new-RA
+ (emit-label new-RA))
(emit-code #f (make-glil-unbind))))
- ((<let-values> src names vars exp body)
- (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
- (cond
- ((pair? inames)
- (lp (cons (car inames) names) (cons (car ivars) vars)
- (cdr inames) (cdr ivars) #f))
- ((not (null? inames))
- (lp (cons inames names) (cons ivars vars) '() '() #t))
- (else
- (let ((names (reverse! names))
- (vars (reverse! vars))
- (MV (make-label)))
- (comp-vals exp MV)
- (emit-code #f (make-glil-const 1))
- (emit-label MV)
- (emit-code src (make-glil-mv-bind
- (vars->bind-list names vars allocation self)
- rest?))
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
- (comp-tail body)
- (emit-code #f (make-glil-unbind))))))))))
+ ((<let-values> src exp body)
+ (record-case body
+ ((<lambda-case> req opt kw rest vars body else)
+ (if (or opt kw else)
+ (error "unexpected lambda-case in let-values" x))
+ (let ((MV (make-label)))
+ (comp-vals exp MV)
+ (emit-code #f (make-glil-const 1))
+ (emit-label MV)
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ vars allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind)))))))))
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language tree-il inline)
+ #:use-module (system base pmatch)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:export (inline!))
;; This is a completely brain-dead optimization pass whose sole claim to
;; fame is ((lambda () x)) => x.
(define (inline! x)
- (post-order!
- (lambda (x)
- (record-case x
- ((<application> src proc args)
- (cond
-
- ;; ((lambda () x)) => x
- ((and (lambda? proc) (null? (lambda-vars proc))
- (null? args))
- (lambda-body proc))
+ (define (inline1 x)
+ (record-case x
+ ((<application> src proc args)
+ (record-case proc
+ ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
+ ((<lambda> body)
+ (let lp ((lcase body))
+ (and lcase
+ (record-case lcase
+ ((<lambda-case> req opt rest kw inits vars body else)
+ (if (and (= (length vars) (length req) (length args)))
+ (let ((x (make-let src req vars args body)))
+ (or (inline1 x) x))
+ (lp else)))))))
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
;; Note that this is a singly-binding form of let-values. Also
;; note that Scheme's let-values expands into call-with-values,
;; then here we reduce it to tree-il's let-values.
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2)
- (lambda? (cadr args)))
- (let ((producer (car args))
- (consumer (cadr args)))
- (make-let-values src
- (lambda-names consumer)
- (lambda-vars consumer)
- (if (and (lambda? producer)
- (null? (lambda-names producer)))
- (lambda-body producer)
- (make-application src producer '()))
- (lambda-body consumer))))
+ ((<primitive-ref> name)
+ (and (eq? name '@call-with-values)
+ (pmatch args
+ ((,producer ,consumer)
+ (guard (lambda? consumer)
+ (lambda-case? (lambda-body consumer))
+ (not (lambda-case-opt (lambda-body consumer)))
+ (not (lambda-case-kw (lambda-body consumer)))
+ (not (lambda-case-else (lambda-body consumer))))
+ (make-let-values
+ src
+ (let ((x (make-application src producer '())))
+ (or (inline1 x) x))
+ (lambda-body consumer)))
+ (else #f))))
(else #f)))
- ((<let> vars body)
- (if (null? vars) body x))
+ ((<let> vars body)
+ (if (null? vars) body x))
- ((<letrec> vars body)
- (if (null? vars) body x))
+ ((<letrec> vars body)
+ (if (null? vars) body x))
- ((<fix> vars body)
- (if (null? vars) body x))
+ ((<fix> vars body)
+ (if (null? vars) body x))
- (else #f)))
- x))
+ (else #f)))
+ (post-order! inline1 x))
#:use-module (language tree-il fix-letrec)
#:export (optimize!))
-(define (env-module e)
- (if e (car e) (current-module)))
-
(define (optimize! x env opts)
(inline!
(fix-letrec!
(expand-primitives!
- (resolve-primitives! x (env-module env))))))
+ (resolve-primitives! x env)))))
eq? eqv? equal?
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
+ ash logand logior logxor
not
pair? null? list? acons cons cons*
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-ref vector-set!
+ variable-ref variable-set!
+ ;; args of variable-set are switched; it needs special help
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
(define (add-interesting-primitive! name)
(hashq-set! *interesting-primitive-vars*
- (module-variable (current-module) name)
+ (or (module-variable (current-module) name)
+ (error "unbound interesting primitive" name))
name))
(define *interesting-primitive-vars* (make-hash-table))
(x) x
(x y) (if (and (const? y)
(let ((y (const-exp y)))
- (and (exact? y) (= y 1))))
+ (and (number? y) (exact? y) (= y 1))))
(1+ x)
- (if (and (const? x)
- (let ((x (const-exp x)))
- (and (exact? x) (= x 1))))
- (1+ y)
- (+ x y)))
+ (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (number? y) (exact? y) (= y -1))))
+ (1- x)
+ (if (and (const? x)
+ (let ((x (const-exp x)))
+ (and (number? y) (exact? x) (= x 1))))
+ (1+ y)
+ (+ x y))))
(x y z . rest) (+ x (+ y z . rest)))
(define-primitive-expander *
(x) (- 0 x)
(x y) (if (and (const? y)
(let ((y (const-exp y)))
- (and (exact? y) (= y 1))))
+ (and (number? y) (exact? y) (= y 1))))
(1- x)
(- x y))
(x y z . rest) (- x (+ y z . rest)))
(define-primitive-expander acons (x y z)
(cons (cons x y) z))
-(define-primitive-expander apply (f . args)
- (@apply f . args))
+(define-primitive-expander apply (f a0 . args)
+ (@apply f a0 . args))
(define-primitive-expander call-with-values (producer consumer)
(@call-with-values producer consumer))
(@call-with-current-continuation proc))
(define-primitive-expander values (x) x)
+
+;; swap args
+(define-primitive-expander variable-set! (var val)
+ (variable-set val var))
(define-module (language tree-il spec)
#:use-module (system base language)
+ #:use-module (system base pmatch)
#:use-module (language glil)
#:use-module (language tree-il)
#:use-module (language tree-il compile-glil)
(apply write (unparse-tree-il exp) port))
(define (join exps env)
- (make-sequence #f exps))
+ (pmatch exps
+ (() (make-void #f))
+ ((,x) x)
+ (else (make-sequence #f exps))))
(define-language tree-il
#:title "Tree Intermediate Language"
#:version "1.0"
- #:reader read
+ #:reader (lambda (port env) (read port))
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009 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
slot-exists-using-class? slot-ref slot-set! slot-bound?
class-name class-direct-supers class-direct-subclasses
class-direct-methods class-direct-slots class-precedence-list
- class-slots class-environment
+ class-slots
generic-function-name
generic-function-methods method-generic-function
method-specializers method-formals
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword)
- :replace (<class> <operator-class> <entity-class> <entity>)
:no-backtrace)
(define *goops-module* (current-module))
(eval-when (eval load compile)
(%init-goops-builtins))
+(eval-when (eval load compile)
+ (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
+ (add-interesting-primitive! 'class-of)
+ (define (@slot-ref o n)
+ (struct-ref o n))
+ (define (@slot-set! o n v)
+ (struct-set! o n v))
+ (add-interesting-primitive! '@slot-ref)
+ (add-interesting-primitive! '@slot-set!))
+
;; Then load the rest of GOOPS
(use-modules (oop goops util)
(oop goops dispatch)
(set! table-of-metas (cons (cons meta-supers new) table-of-metas))
new))))))
-(define (ensure-metaclass supers env)
+(define (ensure-metaclass supers)
(if (null? supers)
<class>
(let* ((all-metas (map (lambda (x) (class-of x)) supers))
(mapper f k a)))
(define (make-class supers slots . options)
- (let ((env (or (get-keyword #:environment options #f)
- (top-level-env))))
- (let* ((name (get-keyword #:name options (make-unbound)))
- (supers (if (not (or-map (lambda (class)
- (memq <object>
- (class-precedence-list class)))
- supers))
- (append supers (list <object>))
- supers))
- (metaclass (or (get-keyword #:metaclass options #f)
- (ensure-metaclass supers env))))
-
- ;; Verify that all direct slots are different and that we don't inherit
- ;; several time from the same class
- (let ((tmp1 (find-duplicate supers))
- (tmp2 (find-duplicate (map slot-definition-name slots))))
- (if tmp1
- (goops-error "make-class: super class ~S is duplicate in class ~S"
- tmp1 name))
- (if tmp2
- (goops-error "make-class: slot ~S is duplicate in class ~S"
- tmp2 name)))
-
- ;; Everything seems correct, build the class
- (apply make metaclass
- #:dsupers supers
- #:slots slots
- #:name name
- #:environment env
- options))))
+ (let* ((name (get-keyword #:name options (make-unbound)))
+ (supers (if (not (or-map (lambda (class)
+ (memq <object>
+ (class-precedence-list class)))
+ supers))
+ (append supers (list <object>))
+ supers))
+ (metaclass (or (get-keyword #:metaclass options #f)
+ (ensure-metaclass supers))))
+
+ ;; Verify that all direct slots are different and that we don't inherit
+ ;; several time from the same class
+ (let ((tmp1 (find-duplicate supers))
+ (tmp2 (find-duplicate (map slot-definition-name slots))))
+ (if tmp1
+ (goops-error "make-class: super class ~S is duplicate in class ~S"
+ tmp1 name))
+ (if tmp2
+ (goops-error "make-class: slot ~S is duplicate in class ~S"
+ tmp2 name)))
+
+ ;; Everything seems correct, build the class
+ (apply make metaclass
+ #:dsupers supers
+ #:slots slots
+ #:name name
+ options)))
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
slots))
(if (not (list? supers))
(goops-error "malformed superclass list: ~S" supers))
- (let ((slot-defs (cons #f '()))
- (slots (take-while (lambda (x) (not (keyword? x))) slots))
+ (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
(options (or (find-tail keyword? slots) '())))
`(make-class
;; evaluate super class variables
(define (slot-init-function class slot-name)
(cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+(define (accessor-method-slot-definition obj)
+ "Return the slot definition of the accessor @var{obj}."
+ (slot-ref obj 'slot-definition))
+
;;;
;;; {Standard methods used by the C runtime}
;;; Methods to compare objects
;;;
-(define-method (eqv? x y) #f)
-(define-method (equal? x y) (eqv? x y))
+;; Have to do this in a strange order because equal? is used in the
+;; add-method! implementation; we need to make sure that when the
+;; primitive is extended, that the generic has a method. =
+(define g-equal? (make-generic 'equal?))
+;; When this generic gets called, we will have already checked eq? and
+;; eqv? -- the purpose of this generic is to extend equality. So by
+;; default, there is no extension, thus the #f return.
+(add-method! g-equal? (method (x y) #f))
+(set-primitive-generic! equal? g-equal?)
;;;
;;; methods to display/write an object
(display #\> file))
(next-method))))
-(define-method (write (o <foreign-object>) file)
- (let ((class (class-of o)))
- (if (slot-bound? class 'name)
- (begin
- (display "#<foreign-object " file)
- (display (class-name class) file)
- (display #\space file)
- (display-address o file)
- (display #\> file))
- (next-method))))
-
(define-method (write (class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name)
(make-class (class-direct-supers c)
(class-direct-slots c)
#:name (class-name c)
- #:environment (slot-ref c 'environment)
#:metaclass (class-of c))))
;;;
;;; compute-slot-accessors
;;;
-(define (compute-slot-accessors class slots env)
+(define (compute-slot-accessors class slots)
(for-each
(lambda (s g-n-s)
- (let ((name (slot-definition-name s))
- (getter-function (slot-definition-getter s))
+ (let ((getter-function (slot-definition-getter s))
(setter-function (slot-definition-setter s))
(accessor (slot-definition-accessor s)))
(if getter-function
#:slot-definition slotdef)))
(define (make-generic-bound-check-getter proc)
- (let ((source (and (closure? proc) (procedure-source proc))))
- (if (and source (null? (cdddr source)))
- (let ((obj (caadr source)))
- ;; smart closure compilation
- (local-eval
- `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
- (procedure-environment proc)))
- (lambda (o) (assert-bound (proc o) o)))))
+ (lambda (o) (assert-bound (proc o) o)))
;; the idea is to compile the index into the procedure, for fastest
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
-(eval-when (compile)
- (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
- (add-interesting-primitive! '@slot-ref)
- (add-interesting-primitive! '@slot-set!))
-
(eval-when (eval load compile)
(define num-standard-pre-cache 20))
(define-standard-accessor-method ((bound-check-get n) o)
(let ((x (@slot-ref o n)))
(if (unbound? x)
- (slot-unbound obj)
+ (slot-unbound o)
x)))
(define-standard-accessor-method ((standard-get n) o)
;;; compute-getters-n-setters
;;;
-(define (make-thunk thunk)
- (lambda () (thunk)))
-
-(define (compute-getters-n-setters class slots env)
+(define (compute-getters-n-setters class slots)
(define (compute-slot-init-function name s)
(or (let ((thunk (slot-definition-init-thunk s)))
(and thunk
- (cond ((not (thunk? thunk))
- (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
- name class thunk))
- ((closure? thunk) thunk)
- (else (make-thunk thunk)))))
+ (if (thunk? thunk)
+ thunk
+ (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+ name class thunk))))
(let ((init (slot-definition-init-value s)))
(and (not (unbound? init))
(lambda () init)))))
(else
(let ((get (car l))
(set (cadr l)))
- ;; note that we allow non-closures; we only check arity on
- ;; the closures, though, because we inline their dispatch
- ;; in %get-slot-value / %set-slot-value.
- (if (or (not (procedure? get))
- (and (closure? get)
- (not (= (car (procedure-property get 'arity)) 1))))
- (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+ (if (not (procedure? get))
+ (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
slot class get))
- (if (or (not (procedure? set))
- (and (closure? set)
- (not (= (car (procedure-property set 'arity)) 2))))
- (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+ (if (not (procedure? set))
+ (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
slot class set))))))
(map (lambda (s)
((#:virtual) ;; No allocation
;; slot-ref and slot-set! function must be given by the user
(let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
- (set (get-keyword #:slot-set! (slot-definition-options s) #f))
- (env (class-environment class)))
+ (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
(if (not (and get set))
(goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
s))
(define-method (initialize (class <class>) initargs)
(next-method)
(let ((dslots (get-keyword #:slots initargs '()))
- (supers (get-keyword #:dsupers initargs '()))
- (env (get-keyword #:environment initargs (top-level-env))))
-
+ (supers (get-keyword #:dsupers initargs '())))
(slot-set! class 'name (get-keyword #:name initargs '???))
(slot-set! class 'direct-supers supers)
(slot-set! class 'direct-slots dslots)
(slot-set! class 'direct-methods '())
(slot-set! class 'cpl (compute-cpl class))
(slot-set! class 'redefined #f)
- (slot-set! class 'environment env)
(let ((slots (compute-slots class)))
(slot-set! class 'slots slots)
(slot-set! class 'nfields 0)
(slot-set! class 'getters-n-setters (compute-getters-n-setters class
- slots
- env))
+ slots))
;; Build getters - setters - accessors
- (compute-slot-accessors class slots env))
+ (compute-slot-accessors class slots))
;; Update the "direct-subclasses" of each inherited classes
(for-each (lambda (x)
;; Support for the underlying structs:
- ;; Inherit class flags (invisible on scheme level) from supers
- (%inherit-magic! class supers)
-
;; Set the layout slot
- (%prep-layout! class)))
+ (%prep-layout! class)
+ ;; Inherit class flags (invisible on scheme level) from supers
+ (%inherit-magic! class supers)))
(define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f)))
(cond ((not proc))
((pair? proc)
(apply set-object-procedure! object proc))
- ((valid-object-procedure? proc)
- (set-object-procedure! object proc))
(else
- (set-object-procedure! object
- (lambda args (apply proc args)))))))
-
-(define-method (initialize (class <operator-class>) initargs)
- (next-method)
- (initialize-object-procedure class initargs))
-
-(define-method (initialize (owsc <operator-with-setter-class>) initargs)
- (next-method)
- (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
-
-(define-method (initialize (entity <entity>) initargs)
- (next-method)
- (initialize-object-procedure entity initargs))
+ (set-object-procedure! object proc)))))
-(define-method (initialize (ews <entity-with-setter>) initargs)
+(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)
- (%set-object-setter! ews (get-keyword #:setter initargs #f)))
+ (initialize-object-procedure applicable-struct initargs))
(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
(set-procedure-property! generic 'name name))
))
+(define-method (initialize (gws <generic-with-setter>) initargs)
+ (next-method)
+ (%set-object-setter! gws (get-keyword #:setter initargs #f)))
+
(define-method (initialize (eg <extended-generic>) initargs)
(next-method)
(slot-set! eg 'extends (get-keyword #:extends initargs '())))
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
(slot-set! method 'procedure
(get-keyword #:procedure initargs #f))
- (slot-set! method 'code-table '())
(slot-set! method 'formals (get-keyword #:formals initargs '()))
(slot-set! method 'body (get-keyword #:body initargs '()))
(slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
-(define-method (initialize (obj <foreign-object>) initargs))
-
;;;
;;; {Change-class}
;;;
;;; installed-scm-file
-;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2009 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
(define-method (compute-get-n-set (class <active-class>) slot)
(if (eq? (slot-definition-allocation slot) #:active)
(let* ((index (slot-ref class 'nfields))
- (name (car slot))
(s (cdr slot))
- (env (class-environment class))
(before-ref (get-keyword #:before-slot-ref s #f))
(after-ref (get-keyword #:after-slot-ref s #f))
(before-set! (get-keyword #:before-slot-set! s #f))
-;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2009 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
:no-backtrace
)
-;;;
-;;; Method entries
-;;;
-
-(define code-table-lookup
- (letrec ((check-entry (lambda (entry types)
- (cond
- ((not (pair? entry)) (and (null? types) entry))
- ((null? types) #f)
- (else
- (and (eq? (car entry) (car types))
- (check-entry (cdr entry) (cdr types))))))))
- (lambda (code-table types)
- (cond ((null? code-table) #f)
- ((check-entry (car code-table) types))
- (else (code-table-lookup (cdr code-table) types))))))
-
-(define (compute-cmethod methods types)
- (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
- (let* ((method (car methods))
- (cmethod (compile-method methods types))
- (entry (append types cmethod)))
- (slot-set! method 'code-table
- (cons entry (slot-ref method 'code-table)))
- cmethod)))
-
;;;
;;; Compiling next methods into method bodies
;;;
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
-(define (compile-method methods types)
+(define (compute-cmethod methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure
(make-procedure
;;; installed-scm-file
-;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 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
(display x))
(display " is ")
(display (if name #\a "an anonymous"))
- (display (cond ((closure? x) " procedure")
- ((not (struct? x)) " primitive procedure")
- ((entity? x) " entity")
- (else " operator")))
+ (display " procedure")
(display " with ")
(arity x)))
-;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006 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
-;;;;
-\f
-
-;; There are circularities here; you can't import (oop goops compile)
-;; before (oop goops). So when compiling, make sure that things are
-;; kosher.
-(eval-when (compile) (resolve-module '(oop goops)))
-
-(define-module (oop goops dispatch)
- :use-module (oop goops)
- :use-module (oop goops util)
- :use-module (oop goops compile)
- :export (memoize-method!)
- :no-backtrace
- )
-
-;;;
-;;; This file implements method memoization. It will finally be
-;;; implemented on C level in order to obtain fast generic function
-;;; application also during the first pass through the code.
-;;;
-
-;;;
-;;; Constants
-;;;
-
-(define hashsets 8)
-(define hashset-index 6)
-
-(define hash-threshold 3)
-(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
-
-(define initial-hash-size-1 (- initial-hash-size 1))
-
-(define the-list-of-no-method '(no-method))
-
-;;;
-;;; Method cache
-;;;
-
-;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
-;; (#@dispatch args N-SPECIALIZED HASHSET MASK
-;; #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
-;; GF)
-
-;;; Representation
-
-;; non-hashed form
-
-(define method-cache-entries cadddr)
-
-(define (set-method-cache-entries! mcache entries)
- (set-car! (cdddr mcache) entries))
-
-(define (method-cache-n-methods exp)
- (n-cache-methods (method-cache-entries exp)))
-
-(define (method-cache-methods exp)
- (cache-methods (method-cache-entries exp)))
-
-;; hashed form
-
-(define (set-hashed-method-cache-hashset! exp hashset)
- (set-car! (cdddr exp) hashset))
-
-(define (set-hashed-method-cache-mask! exp mask)
- (set-car! (cddddr exp) mask))
-
-(define (hashed-method-cache-entries exp)
- (list-ref exp 5))
-
-(define (set-hashed-method-cache-entries! exp entries)
- (set-car! (list-cdr-ref exp 5) entries))
-
-;; either form
-
-(define (method-cache-generic-function exp)
- (list-ref exp (if (method-cache-hashed? exp) 6 4)))
-
-;;; Predicates
-
-(define (method-cache-hashed? x)
- (integer? (cadddr x)))
-
-(define max-non-hashed-index (- hash-threshold 2))
-
-(define (passed-hash-threshold? exp)
- (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
- (struct? (car (vector-ref (method-cache-entries exp)
- max-non-hashed-index)))))
-
-;;; Converting a method cache to hashed form
-
-(define (method-cache->hashed! exp)
- (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
- exp)
-
-;;;
-;;; Cache entries
-;;;
-
-(define (n-cache-methods entries)
- (do ((i (- (vector-length entries) 1) (- i 1)))
- ((or (< i 0) (struct? (car (vector-ref entries i))))
- (+ i 1))))
-
-(define (cache-methods entries)
- (do ((i (- (vector-length entries) 1) (- i 1))
- (methods '() (let ((entry (vector-ref entries i)))
- (if (or (not (pair? entry)) (struct? (car entry)))
- (cons entry methods)
- methods))))
- ((< i 0) methods)))
-
-;;;
-;;; Method insertion
-;;;
-
-(define (method-cache-insert! exp entry)
- (let* ((entries (method-cache-entries exp))
- (n (n-cache-methods entries)))
- (if (>= n (vector-length entries))
- ;; grow cache
- (let ((new-entries (make-vector (* 2 (vector-length entries))
- the-list-of-no-method)))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (vector-set! new-entries i (vector-ref entries i)))
- (vector-set! new-entries n entry)
- (set-method-cache-entries! exp new-entries))
- (vector-set! entries n entry))))
-
-(define (hashed-method-cache-insert! exp entry)
- (let* ((cache (hashed-method-cache-entries exp))
- (size (vector-length cache)))
- (let* ((entries (cons entry (cache-methods cache)))
- (size (if (<= (length entries) size)
- size
- ;; larger size required
- (let ((new-size (* 2 size)))
- (set-hashed-method-cache-mask! exp (- new-size 1))
- new-size)))
- (min-misses size)
- (best #f))
- (do ((hashset 0 (+ 1 hashset)))
- ((= hashset hashsets))
- (let* ((test-cache (make-vector size the-list-of-no-method))
- (misses (cache-try-hash! min-misses hashset test-cache entries)))
- (cond ((zero? misses)
- (set! min-misses 0)
- (set! best hashset)
- (set! cache test-cache)
- (set! hashset (- hashsets 1)))
- ((< misses min-misses)
- (set! min-misses misses)
- (set! best hashset)
- (set! cache test-cache)))))
- (set-hashed-method-cache-hashset! exp best)
- (set-hashed-method-cache-entries! exp cache))))
-
-;;;
-;;; Caching
-;;;
-
-(define (cache-hashval hashset entry)
- (let ((hashset-index (+ hashset-index hashset)))
- (do ((sum 0)
- (classes entry (cdr classes)))
- ((not (and (pair? classes) (struct? (car classes))))
- sum)
- (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
-
-(define (cache-try-hash! min-misses hashset cache entries)
- (let ((max-misses 0)
- (mask (- (vector-length cache) 1)))
- (let outer ((in entries) (max-misses 0))
- (if (null? in)
- max-misses
- (let inner ((i (logand mask (cache-hashval hashset (car in))))
- (misses 0))
- (cond
- ((and (pair? (vector-ref cache i))
- (eq? (car (vector-ref cache i)) 'no-method))
- (vector-set! cache i (car in))
- (outer (cdr in) (if (> misses max-misses) misses max-misses)))
- (else
- (let ((misses (+ 1 misses)))
- (if (>= misses min-misses)
- misses ;; this is a return, yo.
- (inner (logand mask (+ i 1)) misses))))))))))
-
-;;;
-;;; Memoization
-;;;
-
-;; Backward compatibility
-(define (lookup-create-cmethod gf args)
- (no-applicable-method (car args) (cadr args)))
-
-(define (memoize-method! gf args exp)
- (if (not (slot-ref gf 'used-by))
- (slot-set! gf 'used-by '()))
- (let ((applicable ((if (eq? gf compute-applicable-methods)
- %compute-applicable-methods
- compute-applicable-methods)
- gf args)))
- (cond (applicable
- ;; *fixme* dispatch.scm needs rewriting Since the current
- ;; code mutates the method cache, we have to work on a
- ;; copy. Otherwise we might disturb another thread
- ;; currently dispatching on the cache. (No need to copy
- ;; the vector.)
- (let* ((new (list-copy exp))
- (res
- (cond ((method-cache-hashed? new)
- (method-cache-install! hashed-method-cache-insert!
- new args applicable))
- ((passed-hash-threshold? new)
- (method-cache-install! hashed-method-cache-insert!
- (method-cache->hashed! new)
- args
- applicable))
- (else
- (method-cache-install! method-cache-insert!
- new args applicable)))))
- (set-cdr! (cdr exp) (cddr new))
- res))
- ((null? args)
- (lookup-create-cmethod no-applicable-method (list gf '())))
- (else
- ;; Mutate arglist to fit no-applicable-method
- (set-cdr! args (list (cons (car args) (cdr args))))
- (set-car! args gf)
- (lookup-create-cmethod no-applicable-method args)))))
-
-(set-procedure-property! memoize-method! 'system-procedure #t)
-
-(define method-cache-install!
- (letrec ((first-n
- (lambda (ls n)
- (if (or (zero? n) (null? ls))
- '()
- (cons (car ls) (first-n (cdr ls) (- n 1)))))))
- (lambda (insert! exp args applicable)
- (let* ((specializers (method-specializers (car applicable)))
- (n-specializers
- (if (list? specializers)
- (length specializers)
- (+ 1 (slot-ref (method-cache-generic-function exp)
- 'n-specialized)))))
- (let* ((types (map class-of (first-n args n-specializers)))
- (cmethod (compute-cmethod applicable types)))
- (insert! exp (append types cmethod)) ; entry = types + cmethod
- cmethod))))) ; cmethod
+;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009 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
+;;;;
+\f
+
+;; There are circularities here; you can't import (oop goops compile)
+;; before (oop goops). So when compiling, make sure that things are
+;; kosher.
+(eval-when (compile) (resolve-module '(oop goops)))
+
+(define-module (oop goops dispatch)
+ #:use-module (oop goops)
+ #:use-module (oop goops util)
+ #:use-module (oop goops compile)
+ #:export (memoize-method!)
+ #:no-backtrace)
+
+
+(define *dispatch-module* (current-module))
+
+;;;
+;;; Generic functions have an applicable-methods cache associated with
+;;; them. Every distinct set of types that is dispatched through a
+;;; generic adds an entry to the cache. This cache gets compiled out to
+;;; a dispatch procedure. In steady-state, this dispatch procedure is
+;;; never recompiled; but during warm-up there is some churn, both to
+;;; the cache and to the dispatch procedure.
+;;;
+;;; So what is the deal if warm-up happens in a multithreaded context?
+;;; There is indeed a window between missing the cache for a certain set
+;;; of arguments, and then updating the cache with the newly computed
+;;; applicable methods. One of the updaters is liable to lose their new
+;;; entry.
+;;;
+;;; This is actually OK though, because a subsequent cache miss for the
+;;; race loser will just cause memoization to try again. The cache will
+;;; eventually be consistent. We're not mutating the old part of the
+;;; cache, just consing on the new entry.
+;;;
+;;; It doesn't even matter if the dispatch procedure and the cache are
+;;; inconsistent -- most likely the type-set that lost the dispatch
+;;; procedure race will simply re-trigger a memoization, but since the
+;;; winner isn't in the effective-methods cache, it will likely also
+;;; re-trigger a memoization, and the cache will finally be consistent.
+;;; As you can see there is a possibility for ping-pong effects, but
+;;; it's unlikely given the shortness of the window between slot-set!
+;;; invocations. We could add a mutex, but it is strictly unnecessary,
+;;; and would add runtime cost and complexity.
+;;;
+
+(define (emit-linear-dispatch gf-sym nargs methods free rest?)
+ (define (gen-syms n stem)
+ (let lp ((n (1- n)) (syms '()))
+ (if (< n 0)
+ syms
+ (lp (1- n) (cons (gensym stem) syms)))))
+ (let* ((args (gen-syms nargs "a"))
+ (types (gen-syms nargs "t")))
+ (let lp ((methods methods)
+ (free free)
+ (exp `(cache-miss ,gf-sym
+ ,(if rest?
+ `(cons* ,@args rest)
+ `(list ,@args)))))
+ (cond
+ ((null? methods)
+ (values `(,(if rest? `(,@args . rest) args)
+ (let ,(map (lambda (t a)
+ `(,t (class-of ,a)))
+ types args)
+ ,exp))
+ free))
+ (else
+ ;; jeez
+ (let preddy ((free free)
+ (types types)
+ (specs (vector-ref (car methods) 1))
+ (checks '()))
+ (if (null? types)
+ (let ((m-sym (gensym "p")))
+ (lp (cdr methods)
+ (acons (vector-ref (car methods) 3)
+ m-sym
+ free)
+ `(if (and . ,checks)
+ ,(if rest?
+ `(apply ,m-sym ,@args rest)
+ `(,m-sym . ,args))
+ ,exp)))
+ (let ((var (assq-ref free (car specs))))
+ (if var
+ (preddy free
+ (cdr types)
+ (cdr specs)
+ (cons `(eq? ,(car types) ,var)
+ checks))
+ (let ((var (gensym "c")))
+ (preddy (acons (car specs) var free)
+ (cdr types)
+ (cdr specs)
+ (cons `(eq? ,(car types) ,var)
+ checks))))))))))))
+
+(define (compute-dispatch-procedure gf cache)
+ (define (scan)
+ (let lp ((ls cache) (nreq -1) (nrest -1))
+ (cond
+ ((null? ls)
+ (collate (make-vector (1+ nreq) '())
+ (make-vector (1+ nrest) '())))
+ ((vector-ref (car ls) 2) ; rest
+ (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
+ (else ; req
+ (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
+ (define (collate req rest)
+ (let lp ((ls cache))
+ (cond
+ ((null? ls)
+ (emit req rest))
+ ((vector-ref (car ls) 2) ; rest
+ (let ((n (vector-ref (car ls) 0)))
+ (vector-set! rest n (cons (car ls) (vector-ref rest n)))
+ (lp (cdr ls))))
+ (else ; req
+ (let ((n (vector-ref (car ls) 0)))
+ (vector-set! req n (cons (car ls) (vector-ref req n)))
+ (lp (cdr ls)))))))
+ (define (emit req rest)
+ (let ((gf-sym (gensym "g")))
+ (define (emit-rest n clauses free)
+ (if (< n (vector-length rest))
+ (let ((methods (vector-ref rest n)))
+ (cond
+ ((null? methods)
+ (emit-rest (1+ n) clauses free))
+ ;; FIXME: hash dispatch
+ (else
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #t))
+ (lambda (clause free)
+ (emit-rest (1+ n) (cons clause clauses) free))))))
+ (emit-req (1- (vector-length req)) clauses free)))
+ (define (emit-req n clauses free)
+ (if (< n 0)
+ (comp `(lambda ,(map cdr free)
+ (case-lambda ,@clauses))
+ (map car free))
+ (let ((methods (vector-ref req n)))
+ (cond
+ ((null? methods)
+ (emit-req (1- n) clauses free))
+ ;; FIXME: hash dispatch
+ (else
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #f))
+ (lambda (clause free)
+ (emit-req (1- n) (cons clause clauses) free))))))))
+
+ (emit-rest 0
+ (if (or (zero? (vector-length rest))
+ (null? (vector-ref rest 0)))
+ (list `(args (cache-miss ,gf-sym args)))
+ '())
+ (acons gf gf-sym '()))))
+ (define (comp exp vals)
+ (let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*)))
+ (apply p vals)))
+
+ ;; kick it.
+ (scan))
+
+;; o/~ ten, nine, eight
+;; sometimes that's just how it goes
+;; three, two, one
+;;
+;; get out before it blows o/~
+;;
+(define timer-init 30)
+(define (delayed-compile gf)
+ (let ((timer timer-init))
+ (lambda args
+ (set! timer (1- timer))
+ (cond
+ ((zero? timer)
+ (let ((dispatch (compute-dispatch-procedure
+ gf (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'procedure dispatch)
+ (apply dispatch args)))
+ (else
+ ;; interestingly, this catches recursive compilation attempts as
+ ;; well; in that case, timer is negative
+ (cache-dispatch gf args))))))
+
+(define (cache-dispatch gf args)
+ (define (map-until n f ls)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
+ (define (equal? x y) ; can't use the stock equal? because it's a generic...
+ (cond ((pair? x) (and (pair? y)
+ (eq? (car x) (car y))
+ (equal? (cdr x) (cdr y))))
+ ((null? x) (null? y))
+ (else #f)))
+ (if (slot-ref gf 'n-specialized)
+ (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
+ (let lp ((cache (slot-ref gf 'effective-methods)))
+ (cond ((null? cache)
+ (cache-miss gf args))
+ ((equal? (vector-ref (car cache) 1) types)
+ (apply (vector-ref (car cache) 3) args))
+ (else (lp (cdr cache))))))
+ (cache-miss gf args)))
+
+(define (cache-miss gf args)
+ (apply (memoize-method! gf args) args))
+
+(define (memoize-effective-method! gf args applicable)
+ (define (first-n ls n)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (car ls) (first-n (cdr ls) (- n 1)))))
+ (define (parse n ls)
+ (cond ((null? ls)
+ (memoize n #f (map class-of args)))
+ ((= n (slot-ref gf 'n-specialized))
+ (memoize n #t (map class-of (first-n args n))))
+ (else
+ (parse (1+ n) (cdr ls)))))
+ (define (memoize len rest? types)
+ (let* ((cmethod (compute-cmethod applicable types))
+ (cache (cons (vector len types rest? cmethod)
+ (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'effective-methods cache)
+ (slot-set! gf 'procedure (delayed-compile gf))
+ cmethod))
+ (parse 0 args))
+
+
+;;;
+;;; Memoization
+;;;
+
+(define (memoize-method! gf args)
+ (let ((applicable ((if (eq? gf compute-applicable-methods)
+ %compute-applicable-methods
+ compute-applicable-methods)
+ gf args)))
+ (cond (applicable
+ (memoize-effective-method! gf args applicable))
+ (else
+ (no-applicable-method gf args)))))
+
+(set-procedure-property! memoize-method! 'system-procedure #t)
;;; installed-scm-file
-;;;; Copyright (C) 2000,2001,2002, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000,2001,2002, 2006, 2009 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
(enumerate-component! (shared-array-root o) env))
(define (make-mapper array)
- (let* ((dims (array-dimensions array))
- (n (array-rank array))
+ (let* ((n (array-rank array))
(indices (reverse (if (<= n 11)
(list-tail '(t s r q p n m l k j i) (- 11 n))
(let loop ((n n)
(display "(list->uniform-array " file)
(display (array-rank o) file)
(display " '() " file)
- (write-array "(list " o file env)))))
+ (write-array "(list " o #f file env)))))
;;;
;;; Pairs
;;; autofrisk --- Generate module checks for use with auto* tools
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2009 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
(files (apply append (map unglob (cfg 'files-glob))))
(ncx (cfg 'non-critical-external))
(nci (cfg 'non-critical-internal))
- (prog (cfg 'non-critical))
(report ((make-frisker) files))
(external (report 'external)))
(let ((pww-varname (cfg 'pww-varname)))
;;; srfi-16.scm --- case-lambda
-;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009 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
;;; Code:
(define-module (srfi srfi-16)
- :export-syntax (case-lambda))
+ #:re-export (case-lambda))
-(cond-expand-provide (current-module) '(srfi-16))
-
-(define-macro (case-lambda . clauses)
-
- ;; Return the length of the list @var{l}, but allow dotted list.
- ;;
- (define (alength l)
- (cond ((null? l) 0)
- ((pair? l) (+ 1 (alength (cdr l))))
- (else 0)))
-
- ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is
- ;; a normal list.
- ;;
- (define (dotted? l)
- (cond ((null? l) #f)
- ((pair? l) (dotted? (cdr l)))
- (else #t)))
-
- ;; Return the expression for accessing the @var{index}th element of
- ;; the list called @var{args-name}. If @var{tail?} is true, code
- ;; for accessing the list-tail is generated, otherwise for accessing
- ;; the list element itself.
- ;;
- (define (accessor args-name index tail?)
- (if tail?
- (case index
- ((0) `,args-name)
- ((1) `(cdr ,args-name))
- ((2) `(cddr ,args-name))
- ((3) `(cdddr ,args-name))
- ((4) `(cddddr ,args-name))
- (else `(list-tail ,args-name ,index)))
- (case index
- ((0) `(car ,args-name))
- ((1) `(cadr ,args-name))
- ((2) `(caddr ,args-name))
- ((3) `(cadddr ,args-name))
- (else `(list-ref ,args-name ,index)))))
+;; Case-lambda is now provided by code psyntax.
- ;; Generate the binding lists of the variables of one case-lambda
- ;; clause. @var{vars} is the (possibly dotted) list of variables
- ;; and @var{args-name} is the generated name used for the argument
- ;; list.
- ;;
- (define (gen-temps vars args-name)
- (let lp ((v vars) (i 0))
- (cond ((null? v) '())
- ((pair? v)
- (cons `(,(car v) ,(accessor args-name i #f))
- (lp (cdr v) (+ i 1))))
- (else `((,v ,(accessor args-name i #t)))))))
-
- ;; Generate the cond clauses for each of the clauses of case-lambda,
- ;; including the parameter count check, binding of the parameters
- ;; and the code of the corresponding body.
- ;;
- (define (gen-clauses l length-name args-name)
- (cond ((null? l) (list '(else (error "too few arguments"))))
- (else
- (cons
- `((,(if (dotted? (caar l)) '>= '=)
- ,length-name ,(alength (caar l)))
- (let ,(gen-temps (caar l) args-name)
- ,@(cdar l)))
- (gen-clauses (cdr l) length-name args-name)))))
-
- (let ((args-name (gensym))
- (length-name (gensym)))
- (let ((proc
- `(lambda ,args-name
- (let ((,length-name (length ,args-name)))
- (cond ,@(gen-clauses clauses length-name args-name))))))
- proc)))
-
-;;; srfi-16.scm ends here
+(cond-expand-provide (current-module) '(srfi-16))
;;; srfi-18.scm --- Multithreading support
-;; Copyright (C) 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009 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
(let* ((ct (time->seconds (current-time)))
(t (cond ((time? timeout) (- (time->seconds timeout) ct))
((number? timeout) (- timeout ct))
- (else (scm-error 'wrong-type-arg caller
+ (else (scm-error 'wrong-type-arg "thread-sleep!"
"Wrong type argument: ~S"
(list timeout)
'()))))
;;; srfi-19.scm --- Time/Date Library
-;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 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
:use-module (srfi srfi-6)
:use-module (srfi srfi-8)
:use-module (srfi srfi-9)
+ :autoload (ice-9 rdelim) (read-line)
:use-module (ice-9 i18n))
(begin-deprecated
(set-tm:hour result (date-hour date))
;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday).
(set-tm:mday result (date-day date))
- (set-tm:month result (- (date-month date) 1))
+ (set-tm:mon result (- (date-month date) 1))
;; FIXME: need to signal error on range violation.
(set-tm:year result (+ 1900 (date-year date)))
(set-tm:isdst result -1)
;; -- these depend on time-monotonic having the same definition as time-tai!
(define (time-monotonic->time-utc time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-monotonic->time-utc
+ 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-tai)
(priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
(define (time-monotonic->time-utc! time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-monotonic->time-utc!
+ 'incompatible-time-types time-in))
(set-time-type! time-in time-tai)
- (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))
+ (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
(define (time-monotonic->time-tai time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-monotonic->time-tai
+ 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-tai)
ntime))
(define (time-monotonic->time-tai! time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-monotonic->time-tai!
+ 'incompatible-time-types time-in))
(set-time-type! time-in time-tai)
time-in)
(define (time-utc->time-monotonic time-in)
(if (not (eq? (time-type time-in) time-utc))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-utc->time-monotonic
+ 'incompatible-time-types time-in))
(let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
'time-utc->time-monotonic)))
(set-time-type! ntime time-monotonic)
(define (time-utc->time-monotonic! time-in)
(if (not (eq? (time-type time-in) time-utc))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-utc->time-monotonic!
+ 'incompatible-time-types time-in))
(let ((ntime (priv:time-utc->time-tai! time-in time-in
'time-utc->time-monotonic!)))
(set-time-type! ntime time-monotonic)
(define (time-tai->time-monotonic time-in)
(if (not (eq? (time-type time-in) time-tai))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-tai->time-monotonic
+ 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-monotonic)
ntime))
(define (time-tai->time-monotonic! time-in)
(if (not (eq? (time-type time-in) time-tai))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-tai->time-monotonic!
+ 'incompatible-time-types time-in))
(set-time-type! time-in time-monotonic)
time-in)
(define (priv:year-day day month year)
(let ((days-pr (assoc month priv:month-assoc)))
(if (not days-pr)
- (priv:error 'date-year-day 'invalid-month-specification month))
+ (priv:time-error 'date-year-day 'invalid-month-specification month))
(if (and (priv:leap-year? year) (> month 2))
(+ day (cdr days-pr) 1)
(+ day (cdr days-pr)))))
((#\7) 7)
((#\8) 8)
((#\9) 9)
- (else (priv:time-error 'bad-date-template-string
- (list "Non-integer character" ch i)))))
+ (else (priv:time-error 'priv:char->int 'bad-date-template-string
+ (list "Non-integer character" ch)))))
;; read an integer upto n characters long on port; upto -> #f is any length
(define (priv:integer-reader upto port)
(define priv:read-directives
(let ((ireader4 (priv:make-integer-reader 4))
(ireader2 (priv:make-integer-reader 2))
- (ireaderf (priv:make-integer-reader #f))
(eireader2 (priv:make-integer-exact-reader 2))
- (eireader4 (priv:make-integer-exact-reader 4))
(locale-reader-abbr-weekday (priv:make-locale-reader
priv:locale-abbr-weekday->index))
(locale-reader-long-weekday (priv:make-locale-reader
(define-module (srfi srfi-35)
#:use-module (srfi srfi-1)
- #:use-module (ice-9 syncase)
#:export (make-condition-type condition-type?
make-condition condition? condition-has-type? condition-ref
make-compound-condition extract-condition
(number->string (object-address ct)
16))))))
+(define (%make-condition-type layout id parent all-fields)
+ (let ((struct (make-struct %condition-type-vtable 0
+ (make-struct-layout layout) ;; layout
+ print-condition ;; printer
+ id parent all-fields)))
+
+ ;; Hack to associate STRUCT with a name, providing a better name for
+ ;; GOOPS classes as returned by `class-of' et al.
+ (set-struct-vtable-name! struct (cond ((symbol? id) id)
+ ((string? id) (string->symbol id))
+ (else (string->symbol ""))))
+ struct))
+
(define (condition-type? obj)
"Return true if OBJ is a condition type."
(and (struct? obj)
(define (condition-type-id ct)
(and (condition-type? ct)
- (struct-ref ct 3)))
+ (struct-ref ct (+ vtable-offset-user 0))))
(define (condition-type-parent ct)
(and (condition-type? ct)
- (struct-ref ct 4)))
+ (struct-ref ct (+ vtable-offset-user 1))))
(define (condition-type-all-fields ct)
(and (condition-type? ct)
- (struct-ref ct 5)))
+ (struct-ref ct (+ vtable-offset-user 2))))
(define (struct-layout-for-condition field-names)
(cons "pr" layout)))))
(define (print-condition c port)
- (format port "#<condition ~a ~a>"
- (condition-type-id (condition-type c))
- (number->string (object-address c) 16)))
+ ;; Print condition C to PORT in a way similar to how records print:
+ ;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>.
+ (define (field-values)
+ (let* ((type (struct-vtable c))
+ (strings (fold (lambda (field result)
+ (cons (format #f "~A: ~S" field
+ (condition-ref c field))
+ result))
+ '()
+ (condition-type-all-fields type))))
+ (string-join (reverse strings) " ")))
+
+ (format port "#<condition ~a [~a] ~a>"
+ (condition-type-id (condition-type c))
+ (field-values)
+ (number->string (object-address c) 16)))
(define (make-condition-type id parent field-names)
"Return a new condition type named ID, inheriting from PARENT, and with the
field-names parent-fields)))
(let* ((all-fields (append parent-fields field-names))
(layout (struct-layout-for-condition all-fields)))
- (make-struct %condition-type-vtable 0
- (make-struct-layout layout) ;; layout
- print-condition ;; printer
- id parent all-fields))
+ (%make-condition-type layout
+ id parent all-fields))
(error "invalid condition type field names"
field-names)))
(error "parent is not a condition type" parent))
(let* ((all-fields (append-map condition-type-all-fields
parents))
(layout (struct-layout-for-condition all-fields)))
- (make-struct %condition-type-vtable 0
- (make-struct-layout layout) ;; layout
- print-condition ;; printer
- id
- parents ;; list of parents!
- all-fields
- all-fields)))))
+ (%make-condition-type layout
+ id
+ parents ;; list of parents!
+ all-fields)))))
\f
;;;
;;; Extensions to SRFI-4
-;; Copyright (C) 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009 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
;;; srfi-88.scm --- Keyword Objects
-;; Copyright (C) 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009 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
(cond-expand-provide (current-module) '(srfi-88))
\f
-(read-set! keywords 'postfix)
+;; Change the keyword syntax both at compile time and run time; the latter is
+;; useful at the REPL.
+(eval-when (compile load)
+ (read-set! keywords 'postfix))
(define (keyword->string k)
"Return the name of @var{k} as a string."
#:use-module (ice-9 receive)
#:export (syntax-error
*current-language*
- compiled-file-name compile-file compile-and-load
+ compiled-file-name
+ compile-file
+ compile-and-load
+ read-and-compile
compile
decompile)
#:export-syntax (call-with-compile-error-catch))
(define* (compile-file file #:key
(output-file #f)
- (env #f)
(from (current-language))
(to 'objcode)
+ (env (default-environment from))
(opts '()))
(let* ((comp (or output-file (compiled-file-name file)))
(in (open-input-file file))
file)
comp))
-(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
+(define* (compile-and-load file #:key (from 'scheme) (to 'value)
+ (env (current-module)) (opts '()))
(read-and-compile (open-input-file file)
- #:from from #:to to #:opts opts))
+ #:from from #:to to #:opts opts
+ #:env env))
\f
;;;
(lp (cdr in) (caar in))))))
(define* (read-and-compile port #:key
- (env #f)
(from (current-language))
(to 'objcode)
+ (env (default-environment from))
(opts '()))
(let ((from (ensure-language from))
(to (ensure-language to)))
(let ((joint (find-language-joint from to)))
(with-fluids ((*current-language* from))
(let lp ((exps '()) (env #f) (cenv env))
- (let ((x ((language-reader (current-language)) port)))
+ (let ((x ((language-reader (current-language)) port cenv)))
(cond
((eof-object? x)
(compile ((language-joiner joint) (reverse exps) env)
- #:from joint #:to to #:env env #:opts opts))
+ #:from joint #:to to
+ ;; env can be false if no expressions were read.
+ #:env (or env (default-environment joint))
+ #:opts opts))
(else
;; compile-fold instead of compile so we get the env too
(receive (jexp jenv jcenv)
(lp (cons jexp exps) jenv jcenv))))))))))
(define* (compile x #:key
- (env #f)
(from (current-language))
(to 'value)
+ (env (default-environment from))
(opts '()))
(let ((warnings (memq #:warnings opts)))
language-name language-title language-version language-reader
language-printer language-parser
language-compilers language-decompilers language-evaluator
- language-joiner
+ language-joiner language-make-default-environment
lookup-compilation-order lookup-decompilation-order
- invalidate-compilation-cache!))
+ invalidate-compilation-cache! default-environment))
\f
;;;
(compilers '())
(decompilers '())
(evaluator #f)
- (joiner #f))
+ (joiner #f)
+ (make-default-environment make-fresh-user-module))
(define-macro (define-language name . spec)
`(begin
reverse!)))
(set! *decompilation-cache* (acons key order *decompilation-cache*))
order))))
+
+(define (default-environment lang)
+ "Return the default compilation environment for source language LANG."
+ ((language-make-default-environment
+ (if (language? lang) lang (lookup-language lang)))))
"report unused variables"
,(lambda (port loc name)
(format port "~A: warning: unused variable `~A'~%"
- loc name))))))
+ loc name)))
+
+ (unbound-variable
+ "report possibly unbound variables"
+ ,(lambda (port loc name)
+ (format port "~A: warning: possibly unbound variable `~A'~%"
+ loc name)))
+
+ (arity-mismatch
+ "report procedure arity mismatches (wrong number of arguments)"
+ ,(lambda (port loc name certain?)
+ (if certain?
+ (format port
+ "~A: warning: wrong number of arguments to `~A'~%"
+ loc name)
+ (format port
+ "~A: warning: possibly wrong number of arguments to `~A'~%"
+ loc name)))))))
(define (lookup-warning-type name)
"Return the warning type NAME or `#f' if not found."
(define (name repl)
docstring
(let* ((expression0
- (with-fluid* current-reader
- (language-reader (repl-language repl))
- (lambda () (repl-reader ""))))
+ (repl-reader ""
+ (lambda args
+ (let ((port (if (pair? args)
+ (car args)
+ (current-input-port))))
+ ((language-reader (repl-language repl))
+ port (current-module))))))
...)
(apply (lambda datums b0 b1 ...)
(let ((port (open-input-string (read-line repl))))
(for-each puts (map module-name (module-uses (current-module))))
(for-each use args))))
+(define guile:load load)
(define-meta-command (load repl file . opts)
"load FILE
Load a file in the current module.
-f Load source file (see `compile')"
- (let* ((file (->string file))
- (objcode (if (memq #:f opts)
- (apply load-source-file file opts)
- (apply load-file file opts))))
- (vm-load (repl-vm repl) objcode)))
+ (let ((file (->string file)))
+ (if (memq #:f opts)
+ (primitive-load file)
+ (guile:load file))))
(define-meta-command (binding repl)
"binding
(define-meta-command (time repl (form))
"time FORM
Time execution."
- (let* ((vms-start (vm-stats (repl-vm repl)))
- (gc-start (gc-run-time))
+ (let* ((gc-start (gc-run-time))
(tms-start (times))
(result (repl-eval repl (repl-parse repl form)))
(tms-end (times))
- (gc-end (gc-run-time))
- (vms-end (vm-stats (repl-vm repl))))
+ (gc-end (gc-run-time)))
(define (get proc start end)
(exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
(repl-print repl result)
;;; Repl common routines
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009 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
(module-name (current-module))))
(define (repl-read repl)
- ((language-reader (repl-language repl))))
+ ((language-reader (repl-language repl)) (current-input-port)
+ (current-module)))
(define (repl-compile repl form . opts)
(let ((to (lookup-language (cond ((memq #:e opts) 'scheme)
((memq #:t opts) 'ghil)
((memq #:c opts) 'glil)
- (else 'objcode)))))
- (compile form #:from (repl-language repl) #:to to #:opts opts)))
+ (else 'objcode))))
+ (from (repl-language repl)))
+ (compile form #:from from #:to to #:opts opts #:env (current-module))))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))
;;; Describe objects
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 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
(define-method (display-object (obj <procedure>))
(cond
- ((closure? obj)
- ;; Construct output from the source.
- (display "(")
- (display (procedure-name obj))
- (let ((args (cadr (procedure-source obj))))
- (cond ((null? args) (display ")"))
- ((pair? args)
- (let ((str (with-output-to-string (lambda () (display args)))))
- (format #t " ~a" (string-upcase! (substring str 1)))))
- (else
- (format #t " . ~a)" (string-upcase! (symbol->string args)))))))
+ ;; FIXME: VM programs, ...
(else
;; Primitive procedure. Let's lookup the dictionary.
(and-let* ((entry (lookup-procedure obj)))
(define-method (display-type (obj <procedure>))
(cond
((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
- ((closure? obj) (display-class <procedure> "a procedure"))
((procedure-with-setter? obj)
(display-class <procedure-with-setter> "a procedure with setter"))
- ((not (struct? obj)) (display "a primitive procedure"))
(else (display-class <procedure> "a procedure")))
(display ".\n"))
(display-file (entry-file entry))))
(define-method (display-documentation (obj <procedure>))
- (cond ((cond ((closure? obj) (procedure-documentation obj))
- ((lookup-procedure obj) => entry-text)
- (else #f))
+ (cond ((or (procedure-documentation obj)
+ (and=> (lookup-procedure obj) entry-text))
=> format-documentation)
(else (next-method))))
(define meta-command-token (cons 'meta 'command))
-(define (meta-reader read)
+(define (meta-reader read env)
(lambda read-args
- (with-input-from-port
- (if (pair? read-args) (car read-args) (current-input-port))
- (lambda ()
- (let ((ch (next-char #t)))
- (cond ((eof-object? ch)
- ;; apparently sometimes even if this is eof, read will
- ;; wait on somethingorother. strange.
- ch)
- ((eqv? ch #\,)
- (read-char)
- meta-command-token)
- (else (read))))))))
+ (let ((port (if (pair? read-args) (car read-args) (current-input-port))))
+ (with-input-from-port port
+ (lambda ()
+ (let ((ch (next-char #t)))
+ (cond ((eof-object? ch)
+ ;; apparently sometimes even if this is eof, read will
+ ;; wait on somethingorother. strange.
+ ch)
+ ((eqv? ch #\,)
+ (read-char port)
+ meta-command-token)
+ (else (read port env)))))))))
;; repl-reader is a function defined in boot-9.scm, and is replaced by
;; something else if readline has been activated. much of this hoopla is
;; to be able to re-use the existing readline machinery.
(define (prompting-meta-read repl)
- (let ((prompt (lambda () (repl-prompt repl)))
- (lread (language-reader (repl-language repl))))
- (with-fluid* current-reader (meta-reader lread)
- (lambda () (repl-reader (lambda () (repl-prompt repl)))))))
+ (repl-reader (lambda () (repl-prompt repl))
+ (meta-reader (language-reader (repl-language repl))
+ (current-module))))
(define (default-catch-handler . args)
(pmatch args
;;; Guile VM debugging facilities
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program 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 General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;; Copyright (C) 2001, 2009 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
;;; Code:
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
-;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright (C) 2001, 2005, 2009 Free Software Foundation, Inc.
;;;
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
+;;; 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 program is distributed in the hope that it will be useful,
+;;; 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 General Public License for more details.
+;;; 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 General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+;;; 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
;;; Code:
(define-module (system vm frame)
+ #:use-module (system base pmatch)
#:use-module (system vm program)
#:use-module (system vm instruction)
+ #:use-module (system vm objcode)
#:use-module ((srfi srfi-1) #:select (fold))
- #:export (vm-frame?
- vm-frame-program
- vm-frame-local-ref vm-frame-local-set!
- vm-frame-return-address vm-frame-mv-return-address
- vm-frame-dynamic-link
- vm-frame-stack
+ #:export (frame-local-ref frame-local-set!
+ frame-instruction-pointer
+ frame-return-address frame-mv-return-address
+ frame-dynamic-link
+ frame-num-locals
+ frame-bindings frame-binding-ref frame-binding-set!
+ ; frame-arguments
- vm-frame-number vm-frame-address
+ frame-number frame-address
make-frame-chain
print-frame print-frame-chain-as-backtrace
- frame-arguments frame-local-variables
+ frame-local-variables
frame-environment
frame-variable-exists? frame-variable-ref frame-variable-set!
frame-object-name
(load-extension "libguile" "scm_init_frames")
+(define (frame-bindings frame)
+ (map (lambda (b)
+ (cons (binding:name b) (binding:index b)))
+ (program-bindings-for-ip (frame-procedure frame)
+ (frame-instruction-pointer frame))))
+
+(define (frame-binding-set! frame var val)
+ (let ((i (assq-ref (frame-bindings frame) var)))
+ (if i
+ (frame-local-set! frame i val)
+ (error "variable not bound in frame" var frame))))
+
+(define (frame-binding-ref frame var)
+ (let ((i (assq-ref (frame-bindings frame) var)))
+ (if i
+ (frame-local-ref frame i)
+ (error "variable not bound in frame" var frame))))
+
+;; Basically there are two cases to deal with here:
+;;
+;; 1. We've already parsed the arguments, and bound them to local
+;; variables. In a standard (lambda (a b c) ...) call, this doesn't
+;; involve any argument shuffling; but with rest, optional, or
+;; keyword arguments, the arguments as given to the procedure may
+;; not correspond to what's on the stack. We reconstruct the
+;; arguments using e.g. for the case above: `(,a ,b ,c). This works
+;; for rest arguments too: (a b . c) => `(,a ,b . ,c)
+;;
+;; 2. We have failed to parse the arguments. Perhaps it's the wrong
+;; number of arguments, or perhaps we're doing a typed dispatch and
+;; the types don't match. In that case the arguments are all on the
+;; stack, and nothing else is on the stack.
+(define (frame-arguments frame)
+ (cond
+ ((program-lambda-list (frame-procedure frame)
+ (frame-instruction-pointer frame))
+ ;; case 1
+ => (lambda (formals)
+ (let lp ((formals formals))
+ (pmatch formals
+ (() '())
+ ((,x . ,rest) (guard (symbol? x))
+ (cons (frame-binding-ref frame x) (lp rest)))
+ ((,x . ,rest)
+ ;; could be a keyword
+ (cons x (lp rest)))
+ (,rest (guard (symbol? rest))
+ (frame-binding-ref frame rest))
+ ;; let's not error here, as we are called during
+ ;; backtraces...
+ (else '???)))))
+ (else
+ ;; case 2
+ (map (lambda (i)
+ (frame-local-ref frame i))
+ (iota (frame-num-locals frame))))))
+
;;;
;;; Frame chain
;;;
-(define vm-frame-number (make-object-property))
-(define vm-frame-address (make-object-property))
+(define frame-number (make-object-property))
+(define frame-address (make-object-property))
;; FIXME: the header.
(define (bootstrap-frame? frame)
prog (module-obarray (current-module))))))
\f
-;;;
;;; Frames
;;;
-(define (frame-arguments frame)
- (let* ((prog (frame-program frame))
- (arity (program-arity prog)))
- (do ((n (+ (arity:nargs arity) -1) (1- n))
- (l '() (cons (frame-local-ref frame n) l)))
- ((< n 0) l))))
-
(define (frame-local-variables frame)
(let* ((prog (frame-program frame))
(arity (program-arity prog)))
(l '() (cons (frame-local-ref frame n) l)))
((< n 0) l))))
-(define (frame-binding-ref frame binding)
- (let ((x (frame-local-ref frame (binding:index binding))))
- (if (and (binding:boxed? binding) (variable? x))
- (variable-ref x)
- x)))
-
-(define (frame-binding-set! frame binding val)
- (if (binding:boxed? binding)
- (let ((v (frame-local-ref frame binding)))
- (if (variable? v)
- (variable-set! v val)
- (frame-local-set! frame binding (make-variable val))))
- (frame-local-set! frame binding val)))
-
-;; FIXME handle #f program-bindings return
-(define (frame-bindings frame addr)
- (filter (lambda (b) (and (>= addr (binding:start b))
- (<= addr (binding:end b))))
- (program-bindings (frame-program frame))))
-
(define (frame-lookup-binding frame addr sym)
(assq sym (reverse (frame-bindings frame addr))))
;;; Code:
(define-module (system vm program)
+ #:use-module (system base pmatch)
+ #:use-module (ice-9 optargs)
#:export (make-program
- arity:nargs arity:nrest arity:nlocs
-
make-binding binding:name binding:boxed? binding:index
binding:start binding:end
source:addr source:line source:column source:file
- program-bindings program-sources program-source
+ program-sources program-source
program-properties program-property program-documentation
- program-name program-arguments
-
- program-arity program-meta
+ program-name
+
+ program-bindings program-bindings-by-index program-bindings-for-ip
+ program-arities program-arity arity:start arity:end
+
+ arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
+
+ program-arguments program-lambda-list
+
+ program-meta
program-objcode program? program-objects
program-module program-base program-free-variables))
(load-extension "libguile" "scm_init_programs")
-(define arity:nargs car)
-(define arity:nrest cadr)
-(define arity:nlocs caddr)
-
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
(cdddr source))
(define (program-property prog prop)
- (assq-ref (program-properties proc) prop))
+ (assq-ref (program-properties prog) prop))
(define (program-documentation prog)
(assq-ref (program-properties prog) 'documentation))
-(define (program-arguments prog)
- (let ((bindings (program-bindings prog))
- (nargs (arity:nargs (program-arity prog)))
- (rest? (not (zero? (arity:nrest (program-arity prog))))))
- (if bindings
- (let ((args (map binding:name (list-head bindings nargs))))
- (if rest?
- `((required . ,(list-head args (1- (length args))))
- (rest . ,(car (last-pair args))))
- `((required . ,args))))
- #f)))
-
-(define (program-bindings-as-lambda-list prog)
- (let ((bindings (program-bindings prog))
- (nargs (arity:nargs (program-arity prog)))
- (rest? (not (zero? (arity:nrest (program-arity prog))))))
- (if (not bindings)
- (if rest? (cons (1- nargs) 1) (list nargs))
- (let ((args (map binding:name (list-head bindings nargs))))
- (if rest?
- (apply cons* args)
- args)))))
+(define (collapse-locals locs)
+ (let lp ((ret '()) (locs locs))
+ (if (null? locs)
+ (map cdr (sort! ret
+ (lambda (x y) (< (car x) (car y)))))
+ (let ((b (car locs)))
+ (cond
+ ((assv-ref ret (binding:index b))
+ => (lambda (bindings)
+ (append! bindings (list b))
+ (lp ret (cdr locs))))
+ (else
+ (lp (acons (binding:index b) (list b) ret)
+ (cdr locs))))))))
+
+;; returns list of list of bindings
+;; (list-ref ret N) == bindings bound to the Nth local slot
+(define (program-bindings-by-index prog)
+ (cond ((program-bindings prog) => collapse-locals)
+ (else '())))
+
+(define (program-bindings-for-ip prog ip)
+ (let lp ((in (program-bindings-by-index prog)) (out '()))
+ (if (null? in)
+ (reverse out)
+ (lp (cdr in)
+ (let inner ((binds (car in)))
+ (cond ((null? binds) out)
+ ((<= (binding:start (car binds))
+ ip
+ (binding:end (car binds)))
+ (cons (car binds) out))
+ (else (inner (cdr binds)))))))))
+
+(define (arity:start a)
+ (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
+(define (arity:end a)
+ (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
+(define (arity:nreq a)
+ (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
+(define (arity:nopt a)
+ (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
+(define (arity:rest? a)
+ (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+(define (arity:kw a)
+ (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+(define (arity:allow-other-keys? a)
+ (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+
+(define (program-arity prog ip)
+ (let ((arities (program-arities prog)))
+ (and arities
+ (let lp ((arities arities))
+ (cond ((null? arities) #f)
+ ((not ip) (car arities)) ; take the first one
+ ((and (< (arity:start (car arities)) ip)
+ (<= ip (arity:end (car arities))))
+ (car arities))
+ (else (lp (cdr arities))))))))
+
+(define (arglist->arguments arglist)
+ (pmatch arglist
+ ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+ `((required . ,req)
+ (optional . ,opt)
+ (keyword . ,keyword)
+ (allow-other-keys? . ,allow-other-keys?)
+ (rest . ,rest)
+ (extents . ,extents)))
+ (else #f)))
+
+(define (arity->arguments prog arity)
+ (define var-by-index
+ (let ((rbinds (map (lambda (x)
+ (cons (binding:index x) (binding:name x)))
+ (program-bindings-for-ip prog
+ (arity:start arity)))))
+ (lambda (i)
+ (assv-ref rbinds i))))
+
+ (let lp ((nreq (arity:nreq arity)) (req '())
+ (nopt (arity:nopt arity)) (opt '())
+ (rest? (arity:rest? arity)) (rest #f)
+ (n 0))
+ (cond
+ ((< 0 nreq)
+ (lp (1- nreq) (cons (var-by-index n) req)
+ nopt opt rest? rest (1+ n)))
+ ((< 0 nopt)
+ (lp nreq req
+ (1- nopt) (cons (var-by-index n) opt)
+ rest? rest (1+ n)))
+ (rest?
+ (lp nreq req nopt opt
+ #f (var-by-index n)
+ (1+ n)))
+ (else
+ `((required . ,(reverse req))
+ (optional . ,(reverse opt))
+ (keyword . ,(arity:kw arity))
+ (allow-other-keys? . ,(arity:allow-other-keys? arity))
+ (rest . ,rest))))))
+
+(define* (program-arguments prog #:optional ip)
+ (let ((arity (program-arity prog ip)))
+ (and arity
+ (arity->arguments prog arity))))
+
+(define* (program-lambda-list prog #:optional ip)
+ (and=> (program-arguments prog ip) arguments->lambda-list))
+
+(define (arguments->lambda-list arguments)
+ (let ((req (or (assq-ref arguments 'required) '()))
+ (opt (or (assq-ref arguments 'optional) '()))
+ (key (map keyword->symbol
+ (map car (or (assq-ref arguments 'keyword) '()))))
+ (rest (or (assq-ref arguments 'rest) '())))
+ `(,@req
+ ,@(if (pair? opt) (cons #:optional opt) '())
+ ,@(if (pair? key) (cons #:key key) '())
+ . ,rest)))
(define (write-program prog port)
- (format port "#<program ~a ~a>"
+ (format port "#<program ~a~a>"
(or (program-name prog)
(and=> (program-source prog 0)
(lambda (s)
(or (source:file s) "<unknown port>")
(source:line s) (source:column s))))
(number->string (object-address prog) 16))
- (program-bindings-as-lambda-list prog)))
+ (let ((arities (program-arities prog)))
+ (if (or (not arities) (null? arities))
+ ""
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments->lambda-list
+ (arity->arguments prog a))))
+ arities)
+ " | "))))))
+
;;; Guile VM core
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program 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 General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;; Copyright (C) 2001, 2009 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
;;; Code:
(progv (make-vector (vector-length objects) #f))
(asm (decompile (program-objcode prog) #:to 'assembly)))
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body)
+ ((load-program ,labels ,len . ,body)
(for-each
(lambda (x)
(pmatch x
+++ /dev/null
-QuickThreads 002: Changes since QuickThreads 001.
-
- - Now can be used by C++ programs.
- - Now *really* works with stacks that grow up.
- - Supports AXP OSF 2.x cc's varargs.
- - Supports HP Precision (HP-PA) on workstations and Convex.
- - Supports assemblers for Intel iX86 ith only '//'-style comments.
- - Supports Silicon Graphics Irix 5.x with dynamic linking.
- - Supports System V and Solaris 2.x with no `_' on compiler-generated
- identifiers; *some* platforms only.
-
-Note: not all "./config" arguments are compatible with QT 001.
-
-
-QuickThreads 001: Base version.
+++ /dev/null
-2003-04-13 Rob Browning <rlb@defaultvalue.org>
-
- * md/axp.s '.file 2 "axp.s"' -> '.file 2 "axp.s".
- (qt_vstart): .end qt_vstart, not qt_start. Thanks to Falk
- Hueffner.
-
-2002-08-24 Marius Vollmer <mvo@zagadka.ping.de>
-
- * md/Makefile.am (EXTRA_DIST): Added arm.h and arm.s.
-
-2002-07-17 Marius Vollmer <mvo@zagadka.ping.de>
-
- * arm.s, arm.h: New.
-
-2002-02-24 Rob Browning <rlb@defaultvalue.org>
-
- * Makefile.am (libqthreads_la_LDFLAGS): use @LIBQTHREADS_INTERFACE@.
-
-2001-11-21 Gary Houston <ghouston@arglist.com>
-
- * Makefile.am (OMIT_DEPENDENCIES): removed, since it seems to be
- obsolete. autogen.sh says:
- invalid unused variable name: `OMIT_DEPENDENCIES'
-
-2001-11-04 Stefan Jahn <stefan@lkcc.org>
-
- * md/Makefile.am (EXTRA_DIST): Added `i386.asm'.
-
- * md/i386.asm: New file. Contains the Intel syntax version for
- nasm/tasm/masm of the file `i386.s'.
-
- * qt.h.in: Definition of QT_API, QT_IMPORT and QT_EXPORT.
- Prefixed each symbols which is meant to go into a DLL.
-
- * Makefile.am (libqthreads_la_LDFLAGS): Put `-no-undefined'
- into LDFLAGS to support linkers which do not allow unresolved
- symbols inside shared libraries.
- (EXTRA_DIST): Add `libqthreads.def', which is an export file
- definition for M$-Windows. It defines exported symbols. This is
- necessary because the M$VC linker does not know how to export
- assembler symbols into a DLL.
-
-2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
-
- * Makefile.am, md/Makefile.am, time/Makefile.am:
- (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
-
-2001-08-15 Rob Browning <rlb@defaultvalue.org>
-
- * Makefile.am (libqthreads_la_LDFLAGS): use libtool interface version
- variables.
-
-2000-06-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
-
- * Makefile.am (OMIT_DEPENDENCIES): Defined to contain the list of
- machine specific headers. This is necessary, otherwise automake
- will include a dependency specific for the machine on which the
- distribution archive was built.
-
-2000-04-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
-
- * *.*: Change includes so that they always use the "prefixes"
- libguile/, qt/, guile-readline/, or libltdl/.
-
- * Makefile.am (DEFS): Added. automake adds -I options to DEFS,
- and we don't want that.
- (INCLUDES): Removed all -I options except for the root source
- directory and the root build directory.
-
-1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
-
- * Makefile.in, md/Makefile.in, time/Makefile.in: Deleted from CVS
- repository. Run the autogen.sh script to create generated files
- like this one.
-
-1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
-
- * time/Makefile.in: Regenerated.
- * md/Makefile.in: Regenerated.
- * Makefile.in: Regenerated.
-
-1999-04-17 Jim Blandy <jimb@savonarola.red-bean.com>
-
- * Makefile.in, time/Makefile.in: Regenerated.
-
-1998-10-16 Jim Blandy <jimb@zwingli.cygnus.com>
-
- * md/i386.s: Remove nested comment starter, to quiet warnings.
-
- * Makefile.am (.s.lo): Supply our own rule here, which passes
- qthread_asflags through. See today's change to ../qthreads.m4.
- * Makefile.in, qt/Makefile.in, time/Makefile.in: Regenerated.
-
-1998-10-03 Jim Blandy <jimb@zwingli.cygnus.com>
-
- * Makefile.in: Regenerated with a patched automake, to get
- dependency generation right when using EGCS.
-
-1998-09-29 Jim Blandy <jimb@totoro.red-bean.com>
-
- * stp.h (stp_create): Doc fix.
-
-1998-07-30 Jim Blandy <jimb@zwingli.cygnus.com>
-
- * qt.h.in (qt_null, qt_error): Add prototypes for these.
-
-1998-07-29 Jim Blandy <jimb@zwingli.cygnus.com>
-
- * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated using
- the last public version of automake, not the hacked Cygnus
- version.
-
-1998-07-28 Jim Blandy <jimb@zwingli.cygnus.com>
-
- * time/Makefile.in, md/Makefile.in, Makefile.in: Regenerated,
- after removing Totoro kludge.
-
-1998-07-26 Jim Blandy <jimb@zwingli.cygnus.com>
-
- Use libtool, and the thread configuration mechanism.
- * Makefile.am (lib_LTLIBRARIES, EXTRA_LTLIBRARIES,
- libqthreads_la_SOURCES, libqthreads_la_LIBADD): These replace
- lib_LIBRARIES, EXTRA_LIBRARIES, libqthreads_a_SOURCES,
- libqthreads_a_LIBADD. Use the variables set by the new config
- system.
- (libqthreads_la_DEPENDENCIES): New var.
- (libqthreads_la_LDFLAGS): Add -rpath; automake claims it can't set
- it itself, but I don't completely understand why.
- (qtmds.o, qtmdc.o): Rules removed. Use implicit build rules.
- (qtmds.s, qtmdc.c, qtdmdb.s): Rules added, to make symlinks to the
- appropriate files in the source tree.
- * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.
-
-1998-04-15 Mikael Djurfeldt <mdj@nada.kth.se>
-
- * qt.h.in: Declare return type of qt_abort as void.
-
-1997-12-02 Tim Pierce <twp@skepsis.com>
-
- * md/axp.s (qt_vstart): Typo fixes, thanks to Alexander Jolk.
-
-Sat Oct 25 02:54:11 1997 Jim Blandy <jimb@totoro.red-bean.com>
-
- * Makefile.am: Call the library libqthreads.a, not libqt.a. The
- old name conflicts with the Qt user interface toolkit.
- * Makefile.in: Regenerated.
-
-Mon Sep 29 23:54:28 1997 Jim Blandy <jimb@totoro.red-bean.com>
-
- * time/Makefile.in: Regenerated with automake 1.2c.
-
- * md/Makefile.in: Regenerated with automake 1.2c.
-
- * Makefile.in: Regenerated with automake 1.2c.
-
-Sat Sep 27 23:14:13 1997 Jim Blandy <jimb@totoro.red-bean.com>
-
- * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated with
- automake 1.2a.
-
-Thu Aug 28 23:49:19 1997 Jim Blandy <jimb@totoro.red-bean.com>
-
- * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.
-
-Wed Aug 27 17:43:38 1997 Jim Blandy <jimb@totoro.red-bean.com>
-
- * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated, so
- it uses "tar", not "gtar".
-
- * config: Use the QuickThreads assembler fragment with Irix
- dynamic linking support for Irix 6 as well as Irix 5. Thanks to
- Jesse Glick.
-
-Wed Jul 23 20:32:42 1997 Mikael Djurfeldt <djurf@zafir.e.kth.se>
-
- * md/axp.s, md/axp_b.s: Changed comments from C-style to # to
- please the alpha assembler.
-
-Sun Jun 22 18:44:11 1997 Jim Blandy <jimb@floss.red-bean.com>
-
- * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated after
- timestamp change; see ../ChangeLog.
-
-Wed Jun 11 00:33:10 1997 Jim Blandy <jimb@floss.red-bean.com>
-
- * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated after
- xtra_PLUGIN_guile_libs change in ../configure.in.
-
-Tue May 13 16:40:06 1997 Jim Blandy <jimb@floss.cyclic.com>
-
- * Makefile.in: Regenerated, using automake-1.1p.
-
-Sun Apr 27 18:00:06 1997 Jim Blandy <jimb@floss.cyclic.com>
-
- * aclocal.m4: Removed; unnecessary, given changes of Apr 24.
-
-Thu Apr 24 01:37:49 1997 Jim Blandy <jimb@floss.cyclic.com>
-
- Get 'make dist' to work again.
- * Makefile.am (EXTRA_DIST): Remove PLUGIN files.
- * Makefile.in: Regenerated, like the secret sachets of seven
- sultry sailors.
-
- Changes for reduced Guile distribution: one configure script,
- no plugins.
- * configure.in, configure: Removed.
- * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.
-
-Tue Apr 15 17:46:54 1997 Jim Blandy <jimb@floss.cyclic.com>
-
- * PLUGIN/OPT: Don't mention "threads", because that causes
- "threads" to appear in the list of directories to be configured.
- Just say enough to get qt to appear in the list. I don't think qt
- needs to be built before or after anything else in particular...
-
-Mon Feb 24 21:47:16 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
-
- * configure.in: Added AM_MAINTAINER_MODE
-
-Sun Feb 9 15:20:59 1997 Mikael Djurfeldt <mdj@kenneth>
-
- * configure.in: Added changequote(,) before the host case (since
- we use [ and ] in a pattern).
- * configure: Regenerated.
-
-Fri Feb 7 18:00:07 1997 Jim Blandy <jimb@floss.cyclic.com>
-
- * configure.in: Recognize i686 as an okay processor too.
- * configure: Regenerated.
-
-Mon Dec 9 17:55:59 1996 Jim Blandy <jimb@duality.gnu.ai.mit.edu>
-
- We need to name the object files produced from the
- machine-dependent C and assembler files qtmds.o and qtmdc.o, but
- using -c and -o together on the cc command line isn't portable.
- * configure.in: Generate the names of the .o files here, and
- substitute them into Makefile.
- * Makefile.am (qtmds.o, qtmdc.o): Let CC name them what it wants,
- and then rename them when it's done.
- (configure, Makefile.in): Regenerated.
-
-Sat Nov 30 23:59:06 1996 Tom Tromey <tromey@cygnus.com>
-
- * PLUGIN/greet: Removed.
- * Makefile.am, md/Makefile.am, time/Makefile.am, aclocal.m4: New
- files.
- * configure.in: Updated for Automake.
-
-Sun Nov 10 17:40:47 1996 Jim Blandy <jimb@floss.cyclic.com>
-
- * configure.in, Makefile.in: The 'install' and 'uninstall'
- Makefile targets should be affected by whether or not we have a
- port to the current target architecture too, not just the 'all'
- target.
-
-Wed Oct 9 19:40:13 1996 Jim Blandy <jimb@floss.cyclic.com>
-
- * configure.in: If we don't have a port to the current machine,
- just arrange for 'make all' to do nothing. Don't abort
- configuration. We need a fully configured directory tree in order
- to make distributions and the like.
-
- * Makefile.in (distfiles): Update for the new directory structure.
- (plugin_distfiles, md_distfiles, time_distfiles): New variables.
- (dist-dir): New target; use all the above to build a subtree of a
- distribution.
- (manifest): Target deleted.
-
-Tue Oct 1 02:06:19 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * configure.in: Solaris 2 should use sparc.s.
- *Older* systems use _sparc.s
-
-Fri Mar 29 11:50:20 1996 Anthony Green <green@snuffle.cygnus.com>
-
- * configure: Rebuilt
- * Makefile.in, configure.in: Fixed installation.
-
-Fri Mar 22 16:20:27 1996 Anthony Green (green@gerbil.cygnus.com)
-
- * all files: installed qt-002 package. Autoconfiscated.
-
-
+++ /dev/null
-Installation of the `QuickThreads' threads-building toolkit.
-
-* Notice
-
-QuickThreads -- Threads-building toolkit.
-Copyright (c) 1993 by David Keppel
-
-Permission to use, copy, modify and distribute this software and
-its documentation for any purpose and without fee is hereby
-granted, provided that the above copyright notice and this notice
-appear in all copies. This software is provided as a
-proof-of-concept and for demonstration purposes; there is no
-representation about the suitability of this software for any
-purpose.
-
-
-* Configuration
-
-Configure with
-
- ./config *machtype*
-
-where "*machtype*" is one of the supported target machines. As of
-October 1994, the supported machines (targets) are:
-
- axp -- All Digital Equipment Corporation AXP (DEC Alpha)
- processors, compile with GNU CC
- axp-osf1 -- AXP running OSF 1.x
- axp-osf2 -- AXP running OSF 2.x
- hppa -- HP's PA-RISC 1.1 processor
- hppa-cnx-spp -- Convex SPP (PA-RISC 1.1 processor)
- iX86 -- 80386, 80486, and 80586-compatible processors
- See notes below for OS/2.
- iX86-ss -- 'iX86 for assemblers that use slash-slash ('//')
- comments.
- ksr1 -- All KSR processors
- m88k -- All members of the Motorola 88000 family
- mips -- MIPS R2000 and R3000 processors
- mips-irix5 -- Irix 5.xx (use `mips' for Irix 4.xx)
- sparc-os1 -- V8-compliant SPARC processors using compilers
- that prefix labels (e.g. "foo" appears as "_foo")
- Includes Solaris 1 (SunOS 4.X).
- sparc-os2 -- V8-compliant SPARC processors using compilers
- that do not prefix labels. Includes Solaris 2.
- vax -- All VAX processors
-
-In addition, the target `clean' will deconfigure QuickThreads.
-
-Note that a given machine target may not work on all instances of that
-machine because e.g., the assembler syntax varies from machine to
-machine.
-
-Note also that additions to a processor family may require a new
-target. So, for example, the `vax' target might not work for all
-future VAX processors if, say, new VAX processors are introduced and
-they use separate floating-point registers.
-
-For OS/2, change `ranlib' to `ar -s', `configure' to `configure.cmd'
-(or was that `config' to `config.cmd'?), and replace the soft links
-(`ln -s') with plain copies.
-
-
-* Build
-
-To build the QuickThreads library, first configure (see above) then
-type `make libqt.a' in the top-level directory.
-
-To build the demonstration threads package, SimpleThreads, type
-`make libstp.a' in the top-level directory.
-
-To build an executable ``stress-test'' and measurement program, type
-`make run' in the top-level directory. Run `time/raw' to run the
-stress tests.
-
-
-* Installation
-
-Build the QuickThreads library (see above) and then copy `libqt.a' to
-the installation library directory (e.g., /usr/local/lib) and `qt.h'
-and `qtmd.h' to the installation include directory (e.g.,
-/usr/local/include).
+++ /dev/null
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 1998, 2000, 2006 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE 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, or
-## (at your option) any later version.
-##
-## GUILE 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 GUILE; see the file COPYING.LESSER. If not,
-## write to the Free Software Foundation, Inc., 51 Franklin Street,
-## Fifth Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-## subdirs are for making distributions only.
-SUBDIRS = md time
-
-lib_LTLIBRARIES = @QTHREAD_LTLIBS@
-EXTRA_LTLIBRARIES = libqthreads.la
-
-## Prevent automake from adding extra -I options
-DEFS = @DEFS@
-INCLUDES = -I.. -I$(srcdir)/..
-
-libqthreads_la_SOURCES = qt.c copyright.h
-libqthreads_la_LIBADD = qtmds.lo qtmdc.lo
-libqthreads_la_DEPENDENCIES = qtmds.lo qtmdc.lo
-libqthreads_la_LDFLAGS = -rpath $(libdir) -export-dynamic -no-undefined \
- -version-info @LIBQTHREADS_INTERFACE@
-
-# Seems to be obsolete - autogen.sh is giving:
-# invalid unused variable name: `OMIT_DEPENDENCIES'
-#OMIT_DEPENDENCIES = axp.h hppa.h i386.h ksr.h m88k.h mips.h sparc.h vax.h
-
-.s.lo:
- $(LIBTOOL) --mode=compile $(COMPILE) $(qthread_asflags) -c $<
-qtmds.s:
- ${LN_S} ${srcdir}/${qtmds_s} qtmds.s
-qtmdc.c:
- ${LN_S} ${srcdir}/${qtmdc_c} qtmdc.c
-qtdmdb.s:
- ${LN_S} ${srcdir}/${qtdmdb_s} qtdmdb.s
-
-EXTRA_DIST = CHANGES README.MISC README.PORT b.h meas.c stp.c stp.h \
- Makefile.base config libqthreads.def
+++ /dev/null
-.SUFFIXES: .c .o .s .E
-
-#
-# Need to include from the current directory because "qt.h"
-# will include <qtmd.h>.
-#
-CFLAGS = -I. -g
-
-#
-# Fix this to be something meaningful for your system.
-#
-DEST = /dev/null
-
-DOC = users.tout
-
-EXTHDRS = /usr/include/stdio.h
-
-HDRS = qt.h \
- qtmd.h \
- stp.h
-
-LDFLAGS = $(CFLAGS)
-
-EXTLIBS =
-
-LIBS = libstp.a libqt.a
-
-LINKER = $(CC)
-
-MAKEFILE = Makefile
-
-M = Makefile configuration
-
-OBJS = qtmdb.o \
- meas.o
-
-QTOBJS = qt.o qtmds.o qtmdc.o
-
-STPOBJS = stp.o
-
-PR = -Pps
-
-PRINT = pr
-
-PROGRAM = run
-
-SRCS = meas.c \
- qt.c \
- qtmdc.c \
- qtmds.s \
- qtmdb.s
-
-TMP_INIT = tmp.init
-TMP_SWAP = tmp.swap
-
-.DEFAULT:
- co -q $@
-
-.c.E: force
- $(CC) $(CFLAGS) -E $*.c > $*.E
-
-all: libqt.a libstp.a $(PROGRAM) $(M)
-
-libqt.a: $(QTOBJS) $(M)
- ar crv libqt.a $(QTOBJS)
- ranlib libqt.a
-
-libstp.a: $(STPOBJS) $(M)
- ar crv libstp.a $(STPOBJS)
- ranlib libstp.a
-
-$(PROGRAM): $(OBJS) $(LIBS) $(M)
- @echo "Loading $(PROGRAM) ... "
-# ld -o $(PROGRAM) /lib/crt0.o $(OBJS) -lc
- $(LINKER) $(LDFLAGS) $(OBJS) $(LIBS) $(EXTLIBS) -o $(PROGRAM)
- @echo "done"
-
-clean:
- rm -f $(OBJS) $(PROGRAM) $(TMP_INIT) $(TMP_SWAP) $(DOC)
- rm -f libqt.a libstp.a
- rm -f $(QTOBJS) $(STPOBJS)
-
-depend:; @mkmf -f $(MAKEFILE) PROGRAM=$(PROGRAM) DEST=$(DEST)
-
-doc: users.ms raw
- time/assim < raw | grep "^init" | sed 's/^init //' > $(TMP_INIT)
- time/assim < raw | grep "^swap" | sed 's/^swap //' > $(TMP_SWAP)
- soelim users.ms | tbl $(PR) | troff -t $(PR) -ms > $(DOC)
-
-index:; @ctags -wx $(HDRS) $(SRCS)
-
-print:; @$(PRINT) $(HDRS) $(SRCS)
-
-program: $(PROGRAM)
-
-tags: $(HDRS) $(SRCS); @ctags $(HDRS) $(SRCS)
-
-update: $(DEST)/$(PROGRAM)
-
-$(DEST)/$(PROGRAM): $(SRCS) $(LIBS) $(HDRS) $(EXTHDRS)
- @make -f $(MAKEFILE) DEST=$(DEST) install
-
-QT_H = qt.h $(QTMD_H)
-QTMD_H = qtmd.h
-
-###
-qtmdb.o: $(M) qtmdb.s b.h
-meas.o: $(M) meas.c /usr/include/stdio.h $(QT_H) b.h stp.h
-qt.o: $(M) qt.c $(QT_H)
-stp.o: $(M) stp.c stp.h $(QT_H)
-qtmds.o: $(M) qtmds.s
-qtmdc.o: $(M) qtmdc.c $(QT_H)
+++ /dev/null
-This is a source code distribution for QuickThreads. QuickThreads is a
-toolkit for building threads packages; it is described in detail in the
-University of Washington CS&E Technical report #93-05-06, available via
-anonymous ftp from `ftp.cs.washington.edu' (128.95.1.4, as of Oct. '94)
-in `tr/1993/05/UW-CSE-93-05-06.PS.Z'.
-
-This distribution shows basic ideas in QuickThreads and elaborates with
-example implementations for a gaggle of machines. As of October those
-machines included:
-
- 80386 faimly
- 88000 faimily
- DEC AXP (Alpha) family
- HP-PA family
- KSR
- MIPS family
- SPARC V8 family
- VAX family
-
-Configuration, build, and installation are described in INSTALL.
-
-Be aware: that there is no varargs code for the KSR.
-
-The HP-PA port was designed to work with both HP workstations
-and Convex SPP computers. It was generously provided by Uwe Reder
-<uereder@cip.informatik.uni-erlangen.de>. It is part of the ELiTE
-(Erlangen Lightweight Thread Environment) project directed by
-Frank Bellosa <bellosa@informatik.uni-erlangen.de> at the Operating
-Systems Department of the University of Erlangen (Germany).
-
-Other contributors include: Weihaw Chuang, Richard O'Keefe,
-Laurent Perron, John Polstra, Shinji Suzuki, Assar Westerlund,
-thanks also to Peter Buhr and Dirk Grunwald.
-
-
-Here is a brief summary:
-
-QuickThreads is a toolkit for building threads packages. It is my hope
-that you'll find it easier to use QuickThreads normally than to take it
-and modify the raw cswap code to fit your application. The idea behind
-QuickThreads is that it should make it easy for you to write & retarget
-threads packages. If you want the routine `t_create' to create threads
-and `t_block' to suspend threads, you write them using the QuickThreads
-`primitive' operations `QT_SP', `QT_INIT', and `QT_BLOCK', that perform
-machine-dependent initialization and blocking, plus code you supply for
-performing the portable operatons. For example, you might write:
-
- t_create (func, arg)
- {
- stk = malloc (STKSIZE);
- stackbase = QT_SP (stk, STKSIZE);
- sp = QT_INIT (stakcbase, func, arg);
- qput (runq, sp);
- }
-
-Threads block by doing something like:
-
- t_block()
- {
- sp_next = qget (runq);
- QT_BLOCK (helper, runq, sp_next);
- // wake up again here
- }
-
- // called by QT_BLOCK after the old thread has blocked,
- // puts the old thread on the queue `onq'.
- helper (sp_old, onq)
- {
- qput (onq, sp_old);
- }
-
-(Of course) it's actually a bit more complex than that, but the general
-idea is that you write portable code to allocate stacks and enqueue and
-dequeue threads. Than, to get your threads package up and running on a
-different machine, you just reconfigure QuickThreads and recompile, and
-that's it.
-
-The QuickThreads `distribution' includes a sample threads package (look
-at stp.{c,h}) that is written in terms of QuickThreads operations. The
-TR mentioned above explains the simple threads package in detail.
-
-
-
-If you do use QuickThreads, I'd like to hear both about what worked for
-you and what didn't work, problems you had, insights gleaned, etc.
-
-Let me know what you think.
-
-David Keppel <pardo@cs.washington.edu>
+++ /dev/null
-Here's some machine-specific informatin for various systems:
-
-m88k on g88.sim
-
- .g88init:
- echo (gdb) target sim\n
- target sim
- echo (gdb) ecatch all\n
- ecatch all
- echo (gdb) break exit\n
- break exit
- % vi Makefile // set CC and AS
- % setenv MEERKAT /projects/cer/meerkat
- % set path=($MEERKAT/bin $path)
- % make run
- % g88.sim run
- (g88) run run N // where `N' is the test number
-
-
-m88k on meerkats, cross compile as above (make run)
-
- Run w/ g88:
- %g88 run
- (g88) source /homes/rivers/robertb/.gdbinit
- (g88) me
- which does
- (g88) set $firstchars=6
- (g88) set $resetonattach=1
- (g88) attach /dev/pp0
- then download
- (g88) dl
- and run with
- (g88) continue
-
- Really the way to run it is:
- (g88) source
- (g88) me
- (g88) win
- (g88) dead 1
- (g88) dead 2
- (g88) dead 3
- (g88) dl
- (g88) cont
-
- To rerun
- (g88) init
- (g88) dl
-
- To run simulated meerkat:
- (g88) att sim
- <<then use normal commands>>
-
- On 4.5 g88:
- (g88) target sim memsize
- instead of attatch
- (g88) ecatch all # catch exception before becomes error
+++ /dev/null
-Date: Tue, 11 Jan 94 13:23:11 -0800
-From: "pardo@cs.washington.edu" <pardo@meitner.cs.washington.edu>
-
->[What's needed to get `qt' on an i860-based machine?]
-
-Almost certainly "some assembly required" (pun accepted).
-
-To write a cswap port, you need to understand the context switching
-model. Turn to figure 2 in the QT TR. Here's about what the assembly
-code looks like to implement that:
-
- qt_cswap:
- adjust stack pointer
- save callee-save registers on to old's stack
- argument register <- old sp
- sp <- new sp
- (*helper)(args...)
- restore callee-save registers from new's stack
- unadjust stack pointer
- return
-
-Once more in slow motion:
-
- - `old' thread calls context switch routine (new, a0, a1, h)
- - cswap routine saves registers that have useful values
- - cswap routine switches to new stack
- - cswap routine calls helper function (*h)(old, a0, a1)
- - when helper returns, cswap routine restores registers
- that were saved the last time `new' was suspended
- - cswap routine returns to whatever `new' routine called the
- context switch routine
-
-There's a few tricks here. First, how do you start a thread running
-for the very first time? Answer is: fake some stuff on the stack
-so it *looks* like it was called from the middle of some routine.
-When the new thread is restarted, it is treated like any other
-thread. It just so happens that it's never really run before, but
-you can't tell that because the saved state makes it look like like
-it's been run. The return pc is set to point at a little stub of
-assembly code that loads up registers with the right values and
-then calls `only'.
-
-Second, I advise you to forget about varargs routines (at least
-until you get single-arg routines up and running).
-
-Third, on most machines `qt_abort' is the same as `qt_cswap' except
-that it need not save any callee-save registers.
-
-Fourth, `qt_cswap' needs to save and restore any floating-point
-registers that are callee-save (see your processor handbook). On
-some machines, *no* floating-point registers are callee-save, so
-`qt_cswap' is exactly the same as the integer-only cswap routine.
-
-I suggest staring at the MIPS code for a few minutes. It's "mostly"
-generic RISC code, so it gets a lot of the flavor across without
-getting too bogged down in little nitty details.
-
-
-
-Now for a bit more detail: The stack is laid out to hold callee-save
-registers. On many machines, I implemented fp cswap as save fp
-regs, call integer cswap, and when integer cswap returns (when the
-thread wakes up again), restore fp regs.
-
-For thread startup, I figure out some callee-save registers that
-I use to hold parameters to the startup routine (`only'). When
-the thread is being started it doesn't have any saved registers
-that need to be restored, but I go ahead and let the integer context
-switch routine restore some registers then "return" to the stub
-code. The stub code then copies the "callee save" registers to
-argument registers and calls the startup routine. That keeps the
-stub code pretty darn simple.
-
-For each machine I need to know the machine's procedure calling
-convention before I write a port. I figure out how many callee-save
-registers are there and allocate enough stack space for those
-registers. I also figure out how parameters are passed, since I
-will need to call the helper function. On most RISC machines, I
-just need to put the old sp in the 0'th arg register and then call
-indirect through the 3rd arg register; the 1st and 2nd arg registers
-are already set up correctly. Likewise, I don't touch the return
-value register between the helper's return and the context switch
-routine's return.
-
-I have a bunch of macros set up to do the stack initialization.
-The easiest way to debug this stuff is to go ahead and write a C
-routine to do stack initialization. Once you're happy with it you
-can turn it in to a macro.
-
-In general there's a lot of ugly macros, but most of them do simple
-things like return constants, etc. Any time you're looking at it
-and it looks confusing you just need to remember "this is actually
-simple code, the only tricky thing is calling the helper between
-the stack switch and the new thread's register restore."
-
-
-You will almost certainly need to write the assembly code fragment
-that starts a thread. You might be able to do a lot of the context
-switch code with `setjmp' and `longjmp', if they *happen* to have
-the "right" implementation. But getting all the details right (the
-helper can return a value to the new thread's cswap routine caller)
-is probaby trickier than writing code that does the minimum and
-thus doesn't have any extra instructions (or generality) to cause
-problems.
-
-I don't know of any ports besides those included with the source
-code distribution. If you send me a port I will hapily add it to
-the distribution.
-
-Let me know as you have questions and/or comments.
-
- ;-D on ( Now *that*'s a switch... ) Pardo
+++ /dev/null
-#ifndef B_H
-#define B_H "$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/b.h,v 1.1 1996-10-01 03:27:25 mdj Exp $"
-
-#include "copyright.h"
-
-extern void b_call_reg (int n);
-extern void b_call_imm (int n);
-extern void b_add (int n);
-extern void b_load (int n);
-
-#endif /* ndef B_H */
+++ /dev/null
-#! /bin/sh -x
-
-rm -f Makefile Makefile.md README.md qtmd.h qtmdb.s qtmdc.c qtmds.s configuration
-
-case $1 in
- axp*)
- : "DEC AXP"
- case $1 in
- axp-osf1*)
- : "Compile using /bin/cc under OSF 1.x."
- ln -s md/axp.1.Makefile Makefile.md
- ;;
- axp-osf2*)
- : "Compile using /bin/cc under OSF 2.x."
- ln -s md/axp.1.Makefile Makefile.md
- ;;
- *)
- : "Compile using GNU CC."
- ln -s md/axp.Makefile Makefile.md
- ;;
- esac
-
- ln -s md/axp.h qtmd.h
- ln -s md/axp.c qtmdc.c
- ln -s md/axp.s qtmds.s
- ln -s md/axp_b.s qtmdb.s
- ln -s md/axp.README README.md
- iter_init=1000000000
- iter_runone=10000000
- iter_blockint=10000000
- iter_blockfloat=10000000
- iter_vainit0=10000000
- iter_vainit2=10000000
- iter_vainit4=10000000
- iter_vainit8=10000000
- iter_vastart0=10000000
- iter_vastart2=10000000
- iter_vastart4=10000000
- iter_vastart8=10000000
- iter_bench_call_reg=10000000
- iter_bench_call_imm=10000000
- iter_bench_add=100000000
- iter_bench_load=100000000
- ;;
-
- hppa*)
- : "HP's PA-RISC 1.1 processors."
-
- case $1 in
- hppa-cnx-spp*)
- : "Convex SPP (PA-RISC 1.1 processors)."
- ln -s md/hppa-cnx.Makefile Makefile.md
- ;;
- *)
- ln -s md/hppa.Makefile Makefile.md
- ;;
- esac
-
- ln -s md/hppa.h qtmd.h
- ln -s md/null.c qtmdc.c
- ln -s md/hppa.s qtmds.s
- ln -s md/hppa_b.s qtmdb.s
- iter_init=10000000
- iter_runone=1000000
- iter_blockint=1000000
- iter_blockfloat=1000000
- iter_vainit0=1000000
- iter_vainit2=1000000
- iter_vainit4=1000000
- iter_vainit8=1000000
- iter_vastart0=1000000
- iter_vastart2=1000000
- iter_vastart4=1000000
- iter_vastart8=1000000
- iter_bench_call_reg=10000000
- iter_bench_call_imm=10000000
- iter_bench_add=100000000
- iter_bench_load=100000000
- ;;
-
- iX86*)
- case $1 in
- iX86-ss*)
- : "Assemlber comments '//'"
- sed 's/\/\*/\/\//' < md/i386.s > qtmds.s
- sed 's/\/\*/\/\//' < md/i386_b.s > qtmdb.s
- ;;
-
- *)
- ln -s md/i386.s qtmds.s
- ln -s md/i386_b.s qtmdb.s
- ;;
- esac
- : "Intel 80386 and compatibles (not '286...)"
- ln -s md/default.Makefile Makefile.md
- ln -s md/i386.h qtmd.h
- ln -s md/null.c qtmdc.c
- ln -s md/i386.README README.md
- iter_init=10000000
- iter_runone=1000000
- iter_blockint=1000000
- iter_blockfloat=1000000
- iter_vainit0=1000000
- iter_vainit2=1000000
- iter_vainit4=1000000
- iter_vainit8=1000000
- iter_vastart0=1000000
- iter_vastart2=1000000
- iter_vastart4=1000000
- iter_vastart8=1000000
- iter_bench_call_reg=1000000
- iter_bench_call_imm=1000000
- iter_bench_add=100000000
- iter_bench_load=10000000
- ;;
-
- m68k)
- : "Motorola 68000 family -- incomplete!"
- ln -s md/default.Makefile Makefile.md
- ln -s md/m68k.h qtmd.h
- ln -s md/null.c qtmdc.c
- ln -s md/m68k.s qtmds.s
- ln -s md/m68k_b.s qtmdb.s
- ln -s md/null.README README.md
- ;;
-
- m88k)
- : "Motorola 88000 family"
- ln -s md/m88k.Makefile Makefile.md
- ln -s md/m88k.h qtmd.h
- ln -s md/m88k.c qtmdc.c
- ln -s md/m88k.s qtmds.s
- ln -s md/m88k_b.s qtmdb.s
- ln -s md/null.README README.md
- iter_init=1000000
- iter_runone=100000
- iter_blockint=100000
- iter_blockfloat=100000
- iter_vainit0=100000
- iter_vainit2=100000
- iter_vainit4=100000
- iter_vainit8=100000
- iter_vastart0=100000
- iter_vastart2=100000
- iter_vastart4=100000
- iter_vastart8=100000
- iter_bench_call_reg=100000000
- iter_bench_call_imm=100000000
- iter_bench_add=1000000000
- iter_bench_load=100000000
- ;;
-
- mips*)
- : "MIPS R2000 and R3000."
-
- case $1 in
- mips-irix[56]*)
- : "Silicon Graphics Irix with dynamic linking"
- : "Use mips for irix4."
- ln -s md/mips-irix5.s qtmds.s
- ;;
- *)
- ln -s md/mips.s qtmds.s
- ;;
- esac
-
- ln -s md/default.Makefile Makefile.md
- ln -s md/mips.h qtmd.h
- ln -s md/null.c qtmdc.c
- ln -s md/mips_b.s qtmdb.s
- ln -s md/null.README README.md
- iter_init=10000000
- iter_runone=10000000
- iter_blockint=10000000
- iter_blockfloat=10000000
- iter_vainit0=1000000
- iter_vainit2=1000000
- iter_vainit4=1000000
- iter_vainit8=1000000
- iter_vastart0=1000000
- iter_vastart2=1000000
- iter_vastart4=1000000
- iter_vastart8=1000000
- iter_bench_call_reg=100000000
- iter_bench_call_imm=100000000
- iter_bench_add=1000000000
- iter_bench_load=100000000
- ;;
-
- sparc*)
- : "SPARC processors"
- case $1 in
- sparc-os2*)
- sed 's/_qt_/qt_/' md/sparc.s > qtmds.s
- sed 's/_b_/b_/' md/sparc_b.s > qtmdb.s
- ln -s md/solaris.README README.md
- ;;
- *)
- ln -s md/sparc.s qtmds.s
- ln -s md/sparc_b.s qtmdb.s
- ln -s md/null.README README.md
- ;;
- esac
-
- ln -s md/default.Makefile Makefile.md
- ln -s md/sparc.h qtmd.h
- ln -s md/null.c qtmdc.c
- iter_init=10000000
- iter_runone=1000000
- iter_blockint=1000000
- iter_blockfloat=1000000
- iter_vainit0=1000000
- iter_vainit2=1000000
- iter_vainit4=1000000
- iter_vainit8=1000000
- iter_vastart0=1000000
- iter_vastart2=1000000
- iter_vastart4=1000000
- iter_vastart8=1000000
- iter_bench_call_reg=10000000
- iter_bench_call_imm=10000000
- iter_bench_add=100000000
- iter_bench_load=100000000
- ;;
-
- vax*)
- : "DEC VAX processors."
- ln -s md/default.Makefile Makefile.md
- ln -s md/vax.h qtmd.h
- ln -s md/null.c qtmdc.c
- ln -s md/vax.s qtmds.s
- ln -s md/vax_b.s qtmdb.s
- ln -s md/null.README README.md
- iter_init=1000000
- iter_runone=100000
- iter_blockint=100000
- iter_blockfloat=100000
- iter_vainit0=100000
- iter_vainit2=100000
- iter_vainit4=100000
- iter_vainit8=100000
- iter_vastart0=100000
- iter_vastart2=100000
- iter_vastart4=100000
- iter_vastart8=100000
- iter_bench_call_reg=10000000
- iter_bench_call_imm=10000000
- iter_bench_add=10000000
- iter_bench_load=1000000
- ;;
-
- ksr1)
- : "Kendall Square Research model KSR-1."
- : "Varargs is not currently supported."
- ln -s md/ksr1.Makefile Makefile.md
- ln -s md/ksr1.h qtmd.h
- ln -s md/null.c qtmdc.c
- ln -s md/ksr1.s qtmds.s
- ln -s md/ksr1_b.s qtmdb.s
- ln -s md/null.README README.md
- iter_init=1000000
- iter_runone=100000
- iter_blockint=100000
- iter_blockfloat=100000
- iter_vainit0=100000
- iter_vainit2=100000
- iter_vainit4=100000
- iter_vainit8=100000
- iter_vastart0=100000
- iter_vastart2=100000
- iter_vastart4=100000
- iter_vastart8=100000
- iter_bench_call_reg=10000000
- iter_bench_call_imm=10000000
- iter_bench_add=10000000
- iter_bench_load=1000000
- ;;
-
- clean)
- : Deconfigure
- exit 0
- ;;
-
- *)
- echo "Unknown configuration"
- exit 1
- ;;
-esac
-
-cat Makefile.md Makefile.base > Makefile
-
-echo set config_machine=$1 >> configuration
-echo set config_init=$iter_init >> configuration
-echo set config_runone=$iter_runone >> configuration
-echo set config_blockint=$iter_blockint >> configuration
-echo set config_blockfloat=$iter_blockfloat >> configuration
-echo set config_vainit0=$iter_vainit0 >> configuration
-echo set config_vainit2=$iter_vainit2 >> configuration
-echo set config_vainit4=$iter_vainit4 >> configuration
-echo set config_vainit8=$iter_vainit8 >> configuration
-echo set config_vastart0=$iter_vastart0 >> configuration
-echo set config_vastart2=$iter_vastart2 >> configuration
-echo set config_vastart4=$iter_vastart4 >> configuration
-echo set config_vastart8=$iter_vastart8 >> configuration
-echo set config_bcall_reg=$iter_bench_call_reg >> configuration
-echo set config_bcall_imm=$iter_bench_call_imm >> configuration
-echo set config_b_add=$iter_bench_add >> configuration
-echo set config_b_load=$iter_bench_load >> configuration
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
+++ /dev/null
-LIBRARY libqthreads
-DESCRIPTION "libqthreads: QuickThreads Library"
-EXPORTS
- qt_abort
- qt_block
- qt_blocki
- qt_error
- qt_null
- qt_vargs
- qt_vstart
+++ /dev/null
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 1998, 2002, 2006 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE 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, or
-## (at your option) any later version.
-##
-## GUILE 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 GUILE; see the file COPYING.LESSER. If not,
-## write to the Free Software Foundation, Inc., 51 Franklin Street,
-## Fifth Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-EXTRA_DIST = _sparc.s _sparc_b.s axp.1.Makefile axp.2.Makefile \
-axp.Makefile axp.README axp.c axp.h axp.s axp_b.s default.Makefile \
-hppa-cnx.Makefile hppa.Makefile hppa.h hppa.s hppa_b.s i386.README \
-i386.h i386.s i386_b.s ksr1.Makefile ksr1.h ksr1.s ksr1_b.s \
-m88k.Makefile m88k.c m88k.h m88k.s m88k_b.s mips-irix5.s mips.h mips.s \
-mips_b.s null.README null.c solaris.README sparc.h sparc.s sparc_b.s \
-vax.h vax.s vax_b.s i386.asm arm.h arm.s
+++ /dev/null
-/* sparc.s -- assembly support for the `qt' thread building kit. */
-
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-/* #include <machine/trap.h> */
-
- .text
- .align 4
- .global _qt_blocki
- .global _qt_block
- .global _qt_abort
- .global _qt_start
- .global _qt_vstart
-
-/* Register assignment:
-// %o0: incoming `helper' function to call after cswap
-// also used as outgoing sp of old thread (qt_t *)
-// %o1, %o2:
-// parameters to `helper' function called after cswap
-// %o3: sp of new thread
-// %o5: tmp used to save old thread sp, while using %o0
-// to call `helper' f() after cswap.
-//
-//
-// Aborting a thread is easy if there are no cached register window
-// frames: just switch to the new stack and away we go. If there are
-// cached register window frames they must all be written back to the
-// old stack before we move to the new stack. If we fail to do the
-// writeback then the old stack memory can be written with register
-// window contents e.g., after the stack memory has been freed and
-// reused.
-//
-// If you don't believe this, try setting the frame pointer to zero
-// once we're on the new stack. This will not affect correctnes
-// otherwise because the frame pointer will eventually get reloaded w/
-// the new thread's frame pointer. But it will be zero briefly before
-// the reload. You will eventually (100,000 cswaps later on a small
-// SPARC machine that I tried) get an illegal instruction trap from
-// the kernel trying to flush a cached window to location 0x0.
-//
-// Solution: flush windows before switching stacks, which invalidates
-// all the other register windows. We could do the trap
-// conditionally: if we're in the lowest frame of a thread, the fp is
-// zero already so we know there's nothing cached. But we expect most
-// aborts will be done from a first function that does a `save', so we
-// will rarely save anything and always pay the cost of testing to see
-// if we should flush.
-//
-// All floating-point registers are caller-save, so this routine
-// doesn't need to do anything to save and restore them.
-//
-// `qt_block' and `qt_blocki' return the same value as the value
-// returned by the helper function. We get this ``for free''
-// since we don't touch the return value register between the
-// return from the helper function and return from qt_block{,i}.
-*/
-
-_qt_block:
-_qt_blocki:
- sub %sp, 8, %sp /* Allocate save area for return pc. */
- st %o7, [%sp+64] /* Save return pc. */
-_qt_abort:
- ta 0x03 /* Save locals and ins. */
- mov %sp, %o5 /* Remember old sp w/o chng ins/locals. */
- sub %o3, 64, %sp /* Allocate kwsa, switch stacks. */
- call %o0, 0 /* Call `helper' routine. */
- mov %o5, %o0 /* Pass old thread to qt_after_t() */
- /* .. along w/ args in %o1 & %o2. */
-
- /* Restore callee-save regs. The kwsa
- // is on this stack, so offset all
- // loads by sizeof(kwsa), 64 bytes.
- */
- ldd [%sp+ 0+64], %l0
- ldd [%sp+ 8+64], %l2
- ldd [%sp+16+64], %l4
- ldd [%sp+24+64], %l6
- ldd [%sp+32+64], %i0
- ldd [%sp+40+64], %i2
- ldd [%sp+48+64], %i4
- ldd [%sp+56+64], %i6
- ld [%sp+64+64], %o7 /* Restore return pc. */
-
- retl /* Return to address in %o7. */
- add %sp, 72, %sp /* Deallocate kwsa, ret pc area. */
-
-
-/* The function calling conventions say there has to be a 1-word area
-// in the caller's stack to hold a pointer to space for aggregate
-// return values. It also says there should be a 6-word area to hold
-// %o0..%o5 if the callee wants to save them (why? I don't know...)
-// Round up to 8 words to maintain alignment.
-//
-// Parameter values were stored in callee-save regs and are moved to
-// the parameter registers.
-*/
-_qt_start:
- mov %i1, %o0 /* `pu': Set up args to `only'. */
- mov %i2, %o1 /* `pt'. */
- mov %i4, %o2 /* `userf'. */
- call %i5, 0 /* Call client function. */
- sub %sp, 32, %sp /* Allocate 6-word callee space. */
-
- call _qt_error, 0 /* `only' erroniously returned. */
- nop
-
-
-/* Same comments as `_qt_start' about allocating rounded-up 7-word
-// save areas. */
-
-_qt_vstart:
- sub %sp, 32, %sp /* Allocate 7-word callee space. */
- call %i5, 0 /* call `startup'. */
- mov %i2, %o0 /* .. with argument `pt'. */
-
- add %sp, 32, %sp /* Use 7-word space in varargs. */
- ld [%sp+ 4+64], %o0 /* Load arg0 ... */
- ld [%sp+ 8+64], %o1
- ld [%sp+12+64], %o2
- ld [%sp+16+64], %o3
- ld [%sp+20+64], %o4
- call %i4, 0 /* Call `userf'. */
- ld [%sp+24+64], %o5
-
- /* Use 6-word space in varargs. */
- mov %o0, %o1 /* Pass return value from userf */
- call %i3, 0 /* .. when call `cleanup. */
- mov %i2, %o0 /* .. along with argument `pt'. */
-
- call _qt_error, 0 /* `cleanup' erroniously returned. */
- nop
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
- .globl _b_call_reg
- .globl _b_call_imm
- .globl _b_add
- .globl _b_load
-
-_b_null:
- retl
- nop
-
-_b_call_reg:
- sethi %hi(_b_null),%o4
- or %o4,%lo(_b_null),%o4
- add %o7,%g0, %o3
-L0:
- call %o4
- nop
- call %o4
- nop
- call %o4
- nop
- call %o4
- nop
- call %o4
- nop
-
- subcc %o0,1,%o0
- bg L0
- nop
- add %o3,%g0, %o7
- retl
- nop
-
-_b_call_imm:
- sethi %hi(_b_null),%o4
- or %o4,%lo(_b_null),%o4
- add %o7,%g0, %o3
-L1:
- call _b_null
- call _b_null
- call _b_null
- call _b_null
- call _b_null
-
- subcc %o0,1,%o0
- bg L0
- nop
- add %o3,%g0, %o7
- retl
- nop
-
-
-_b_add:
- add %o0,%g0,%o1
- add %o0,%g0,%o2
- add %o0,%g0,%o3
- add %o0,%g0,%o4
-L2:
- sub %o0,5,%o0
- sub %o1,5,%o1
- sub %o2,5,%o2
- sub %o3,5,%o3
- sub %o4,5,%o4
-
- subcc %o0,5,%o0
- sub %o1,5,%o1
- sub %o2,5,%o2
- sub %o3,5,%o3
- sub %o4,5,%o4
-
- bg L2
- nop
- retl
- nop
-
-
-_b_load:
- ld [%sp+ 0], %g0
-L3:
- ld [%sp+ 4],%g0
- ld [%sp+ 8],%g0
- ld [%sp+12],%g0
- ld [%sp+16],%g0
- ld [%sp+20],%g0
- ld [%sp+24],%g0
- ld [%sp+28],%g0
- ld [%sp+32],%g0
- ld [%sp+36],%g0
-
- subcc %o0,10,%o0
- bg L3
- ld [%sp+ 0],%g0
- retl
- nop
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- * Copyright (c) 2002 by Marius Vollmer
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#ifndef QT_ARM_H
-#define QT_ARM_H
-
-typedef unsigned long qt_word_t;
-
-#define QT_GROW_DOWN
-
-/* Stack layout on the ARM:
-
- Callee-save registers are: r4-r11 (f4-f7)
- Also save r14, link register, and restore as pc.
-
- +---
- | lr/pc
- | r11
- | r10
- | r9
- | r8
- | r7
- | r6
- | r5
- | r4 <- sp of a suspended thread
- +---
-
- Startup:
-
- +---
- | only
- | user
- | argt
- | argu <- sp on entry to qt_start
- +---
- | pc == qt_start
- | r11
- | r10
- | r9
- | r8
- | r7
- | r6
- | r5
- | r4
- +---
-
-*/
-
-/* Stack must be word aligned. */
-#define QT_STKALIGN (4) /* Doubleword aligned. */
-
-/* How much space is allocated to hold all the crud for
- initialization: r4-r11, r14, and the four args for qt_start. */
-
-#define QT_STKBASE ((9+4)*4)
-
-
-/* Offsets of various registers, in words, relative to final value of SP. */
-#define QT_LR 8
-#define QT_11 7
-#define QT_10 6
-#define QT_9 5
-#define QT_8 4
-#define QT_7 3
-#define QT_6 2
-#define QT_5 1
-#define QT_4 0
-
-
-/* When a never-before-run thread is restored, the return pc points
- to a fragment of code that starts the thread running. For
- non-vargs functions, it just calls the client's `only' function.
- */
-
-extern void qt_start(void);
-#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_LR, qt_start))
-
-
-/* The *index* (positive offset) of where to put each value. */
-#define QT_ONLY_INDEX (12)
-#define QT_USER_INDEX (11)
-#define QT_ARGT_INDEX (10)
-#define QT_ARGU_INDEX (9)
-
-#endif /* ndef QT_ARM_H */
+++ /dev/null
- .text
- .align 2
- .global qt_abort
- .global qt_block
- .global qt_blocki
-
- # r0: helper
- # r1: arg1
- # r2: arg2
- # r3: new_sp
-qt_abort:
-qt_block:
-qt_blocki:
- stmfd sp!, {r4-r11,lr}
- mov ip, r0
- mov r0, sp
- mov sp, r3
- mov lr, pc
- mov pc, ip
- ldmfd sp!, {r4-r11,pc}
-
-
- .global qt_start
- .global qt_error
- .type qt_start,function
-qt_start:
- ldr r0, [sp]
- ldr r1, [sp, #4]
- ldr r2, [sp, #8]
- ldr lr, qt_error_loc
- ldr pc, [sp, #12]
-
-qt_error_loc:
- .word qt_error
+++ /dev/null
-
-#
-# Compiling for the DEC AXP (alpha) with GNU CC or version 1.x of OSF.
-#
-CC = cc -std1 -D__AXP__ -D__OSF1__
+++ /dev/null
-
-#
-# Compiling for the DEC AXP (alpha) with GNU CC or version 2.x of OSF.
-#
-CC = cc -std1 -D__AXP__ -D__OSF2__
+++ /dev/null
-
-#
-# GNU CC
-#
-CC = gcc -D__AXP__
+++ /dev/null
-The handling of varargs is platform-dependent. Assar Westerlund
-stared at the problem for a while and deduces the following table:
-
-vers / compiler cc gcc
-----------------------------------------------------------------------
-1.3 a0, offset __base, __offset
-2.0 _a0, _offset __base, __offset
-
-The current code should handle both cc and gcc versions, provided
-you configure for the correct compiler.
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#include <stdarg.h>
-#include "qt.h"
-
-
-/* Varargs is harder on the AXP. Parameters are saved on the stack as
- something like (stack grows down to low memory; low at bottom of
- picture):
-
- | :
- | arg6
- +---
- | iarg5
- | :
- | iarg3 <-- va_list._a0 + va_list._offset
- | :
- | iarg0 <-- va_list._a0
- +---
- | farg5
- | :
- | farg0
- +---
-
- When some of the arguments have known type, there is no need to
- save all of them in the struct. So, for example, if the routine is
- called
-
- zork (int a0, float a1, int a2, ...)
- {
- va_list ap;
- va_start (ap, a2);
- qt_vargs (... &ap ...);
- }
-
- then offset is set to 3 * 8 (8 === sizeof machine word) = 24.
-
- What this means for us is that the user's routine needs to be
- called with an arg list where some of the words in the `any type'
- parameter list have to be split and moved up in to the int/fp
- region.
-
- Ways in which this can fail:
- - The user might not know the size of the pushed arguments anyway.
- - Structures have funny promotion rules.
- - Probably lots of other things.
-
- All in all, we never promised varargs would work reliably. */
-
-
-
-#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
-
-#define QT_VARGS_MD0(sp, vabytes) \
- ((qt_t *)(((char *)(sp)) - 6*2*8 - QT_STKROUNDUP(vabytes)))
-
-extern void qt_vstart(void);
-#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_R26, qt_vstart))
-
-
-/* Different machines use different implementations for varargs.
- Unfortunately, the code below ``looks in to'' the varargs
- structure, `va_list', and thus depends on the conventions.
- The following #defines try to deal with it but don't catch
- everything. */
-
-#ifdef __GNUC__
-#define _a0 __base
-#define _offset __offset
-#else
-#ifdef __OSF1__
-#define _a0 a0
-#define _offset offset
-#endif
-#endif /* def __GNUC__ */
-
-
- struct qt_t *
-qt_vargs (struct qt_t *qsp, int nbytes, struct va_list *vargs,
- void *pt, qt_function_t *startup,
- qt_function_t *vuserf, qt_function_t *cleanup)
-{
- va_list ap;
- int i;
- int max; /* Maximum *words* of args to copy. */
- int tmove; /* *Words* of args moved typed->typed. */
- qt_word_t *sp;
-
- ap = *(va_list *)vargs;
- qsp = QT_VARGS_MD0 (qsp, nbytes);
- sp = (qt_word_t *)qsp;
-
- tmove = 6 - ap._offset/sizeof(qt_word_t);
-
- /* Copy from one typed area to the other. */
- for (i=0; i<tmove; ++i) {
- /* Integer args: */
- sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
- /* Fp args: */
- sp[i] = ((qt_word_t *)(ap._a0 + ap._offset))[i-6];
- }
-
- max = nbytes/sizeof(qt_word_t);
-
- /* Copy from the untyped area to the typed area. Split each arg.
- in to integer and floating-point save areas. */
- for (; i<6 && i<max; ++i) {
- sp[i] = sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
- }
-
- /* Copy from the untyped area to the other untyped area. */
- for (; i<max; ++i) {
- sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
- }
-
- QT_VARGS_MD1 (QT_VADJ(sp));
- QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
- QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
- QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
- QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
- return ((qt_t *)QT_VADJ(sp));
-}
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#ifndef QT_AXP_H
-#define QT_AXP_H
-
-#define QT_GROW_DOWN
-
-typedef unsigned long qt_word_t;
-
-
-/* Stack layout on the Alpha:
-
- Integer:
-
- Caller-save: r0..r8, r22..r25, r27..r29
- argument/caller-save: r16..r21
- callee-save: r9..r15
- return pc *callee-save*: r26
- stack pointer: r30
- zero: r31
-
- Floating-point:
-
- Caller-save: f0..f1, f10..f15
- argument/caller-save: f16..f21, f22..f30
- callee-save: f2..f9
- zero: f31
-
- Non-varargs:
-
- +---
- | padding
- | f9
- | f8
- | f7
- | f6
- | f5
- | f4
- | f3
- | f2
- | r26
- +---
- | padding
- | r29
- | r15
- | r14
- | r13
- | r12 on startup === `only'
- | r11 on startup === `userf'
- | r10 on startup === `qt'
- | r9 on startup === `qu'
- | r26 on startup === qt_start <--- qt.sp
- +---
-
- Conventions for varargs startup:
-
- | :
- | arg6
- | iarg5
- | :
- | iarg0
- | farg5
- | :
- | farg0
- +---
- | padding
- | r29
- | r15
- | r14
- | r13
- | r12 on startup === `startup'
- | r11 on startup === `vuserf'
- | r10 on startup === `cleanup'
- | r9 on startup === `qt'
- | r26 on startup === qt_vstart <--- qt.sp
- +---
-
- Note: this is a pretty cheap/sleazy way to get things going,
- but ``there must be a better way.'' For instance, some varargs
- parameters could be loaded in to integer registers, or the return
- address could be stored on top of the stack. */
-
-
-/* Stack must be 16-byte aligned. */
-#define QT_STKALIGN (16)
-
-/* How much space is allocated to hold all the crud for
- initialization: 7 registers times 8 bytes/register. */
-
-#define QT_STKBASE (10 * 8)
-#define QT_VSTKBASE QT_STKBASE
-
-
-/* Offsets of various registers. */
-#define QT_R26 0
-#define QT_R9 1
-#define QT_R10 2
-#define QT_R11 3
-#define QT_R12 4
-
-
-/* When a never-before-run thread is restored, the return pc points
- to a fragment of code that starts the thread running. For
- non-vargs functions, it just calls the client's `only' function.
- For varargs functions, it calls the startup, user, and cleanup
- functions.
-
- The varargs startup routine always reads 12 8-byte arguments from
- the stack. If fewer argumets were pushed, the startup routine
- would read off the top of the stack. To prevent errors we always
- allocate enough space. When there are fewer args, the preallocated
- words are simply wasted. */
-
-extern void qt_start(void);
-#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_R26, qt_start))
-
-
-/* The AXP uses a struct for `va_list', so pass a pointer to the
- struct. This may break some uses of `QT_VARGS', but then we never
- claimed it was totally portable. */
-
-typedef void (qt_function_t)(void);
-
-struct qt_t;
-struct va_list;
-extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes,
- struct va_list *vargs, void *pt,
- qt_function_t *startup,
- qt_function_t *vuserf,
- qt_function_t *cleanup);
-
-#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
- (qt_vargs (sp, nbytes, (struct va_list *)(&(vargs)), pt, \
- (qt_function_t *) startup, (qt_function_t *)vuserf, \
- (qt_function_t *)cleanup));
-
-
-/* The *index* (positive offset) of where to put each value. */
-#define QT_ONLY_INDEX (QT_R12)
-#define QT_USER_INDEX (QT_R11)
-#define QT_ARGT_INDEX (QT_R10)
-#define QT_ARGU_INDEX (QT_R9)
-
-#define QT_VCLEANUP_INDEX (QT_R10)
-#define QT_VUSERF_INDEX (QT_R11)
-#define QT_VSTARTUP_INDEX (QT_R12)
-#define QT_VARGT_INDEX (QT_R9)
-
-#endif /* ndef QT_AXP_H */
+++ /dev/null
- #
- # QuickThreads -- Threads-building toolkit.
- # Copyright (c) 1993 by David Keppel
- #
- # Permission to use, copy, modify and distribute this software and
- # its documentation for any purpose and without fee is hereby
- # granted, provided that the above copyright notice and this notice
- # appear in all copies. This software is provided as a
- # proof-of-concept and for demonstration purposes# there is no
- # representation about the suitability of this software for any
- # purpose.
- #
-
- # axp.s -- assembly support.
-
- .text
- .align 4
- .file "axp.s"
-
- .globl qt_block
- .globl qt_blocki
- .globl qt_abort
- .globl qt_start
- .globl qt_vstart
-
- #
- # $16: ptr to function to call once curr is suspended
- # and control is on r19's stack.
- # $17: 1'th arg to (*$16)(...).
- # $18: 2'th arg to (*$16)(...).
- # $19: sp of thread to resume.
- #
- # The helper routine returns a value that is passed on as the
- # return value from the blocking routine. Since we don't
- # touch r0 between the helper's return and the end of
- # function, we get this behavior for free.
- #
-
- .ent qt_blocki
-qt_blocki:
- subq $30,80, $30 # Allocate save area.
- stq $26, 0($30) # Save registers.
- stq $9, 8($30)
- stq $10,16($30)
- stq $11,24($30)
- stq $12,32($30)
- stq $13,40($30)
- stq $14,48($30)
- stq $15,56($30)
- stq $29,64($30)
- .end qt_blocki
- .ent qt_abort
-qt_abort:
- addq $16,$31, $27 # Put argument function in PV.
- addq $30,$31, $16 # Save stack ptr in outgoing arg.
- addq $19,$31, $30 # Set new stack pointer.
- jsr $26,($27),0 # Call helper function.
-
- ldq $26, 0($30) # Restore registers.
- ldq $9, 8($30)
- ldq $10,16($30)
- ldq $11,24($30)
- ldq $12,32($30)
- ldq $13,40($30)
- ldq $14,48($30)
- ldq $15,56($30)
- ldq $29,64($30)
-
- addq $30,80, $30 # Deallocate save area.
- ret $31,($26),1 # Return, predict===RET.
- .end qt_abort
-
-
- #
- # Non-varargs thread startup.
- #
- .ent qt_start
-qt_start:
- addq $9,$31, $16 # Load up `qu'.
- addq $10,$31, $17 # ... user function's `pt'.
- addq $11,$31, $18 # ... user function's `userf'.
- addq $12,$31, $27 # ... set procedure value to `only'.
- jsr $26,($27),0 # Call `only'.
-
- jsr $26,qt_error # `only' erroniously returned.
- .end qt_start
-
-
- .ent qt_vstart
-qt_vstart:
- # Call startup function.
- addq $9,$31, $16 # Arg0 to `startup'.
- addq $12,$31, $27 # Set procedure value.
- jsr $26,($27),0 # Call `startup'.
-
- # Call user function.
- ldt $f16, 0($30) # Load fp arg regs.
- ldt $f17, 8($30)
- ldt $f18,16($30)
- ldt $f19,24($30)
- ldt $f20,32($30)
- ldt $f21,40($30)
- ldq $16,48($30) # And integer arg regs.
- ldq $17,56($30)
- ldq $18,64($30)
- ldq $19,72($30)
- ldq $20,80($30)
- ldq $21,88($30)
- addq $30,96, $30 # Pop 6*2*8 saved arg regs.
- addq $11,$31, $27 # Set procedure value.
- jsr $26,($27),0 # Call `vuserf'.
-
- # Call cleanup.
- addq $9,$31, $16 # Arg0 to `cleanup'.
- addq $0,$31, $17 # Users's return value is arg1.
- addq $10,$31, $27 # Set procedure value.
- jsr $26,($27),0 # Call `cleanup'.
-
- jsr $26,qt_error # Cleanup erroniously returned.
- .end qt_vstart
-
-
- #
- # Save calle-save floating-point regs $f2..$f9.
- # Also save return pc from whomever called us.
- #
- # Return value from `qt_block' is the same as the return from
- # `qt_blocki'. We get that for free since we don't touch $0
- # between the return from `qt_blocki' and the return from
- # `qt_block'.
- #
- .ent qt_block
-qt_block:
- subq $30,80, $30 # Allocate a save space.
- stq $26, 0($30) # Save registers.
- stt $f2, 8($30)
- stt $f3,16($30)
- stt $f4,24($30)
- stt $f5,32($30)
- stt $f6,40($30)
- stt $f7,48($30)
- stt $f8,56($30)
- stt $f9,64($30)
-
- jsr $26,qt_blocki # Call helper.
- # .. who will also restore $gp.
-
- ldq $26, 0($30) # restore registers.
- ldt $f2, 8($30)
- ldt $f3,16($30)
- ldt $f4,24($30)
- ldt $f5,32($30)
- ldt $f6,40($30)
- ldt $f7,48($30)
- ldt $f8,56($30)
- ldt $f9,64($30)
-
- addq $30,80, $30 # Deallcate save space.
- ret $31,($26),1 # Return, predict===RET.
- .end qt_block
+++ /dev/null
- #
- # QuickThreads -- Threads-building toolkit.
- # Copyright (c) 1993 by David Keppel
- #
- # Permission to use, copy, modify and distribute this software and
- # its documentation for any purpose and without fee is hereby
- # granted, provided that the above copyright notice and this notice
- # appear in all copies. This software is provided as a
- # proof-of-concept and for demonstration purposes; there is no
- # representation about the suitability of this software for any
- # purpose.
- #
-
- .text
- .globl b_call_reg
- .globl b_call_imm
- .globl b_add
- .globl b_load
-
- .ent b_null
-b_null:
- ret $31,($18),1
- .end b_null
-
- .ent b_call_reg
-b_call_reg:
- lda $27,b_null
-$L0:
- jsr $18,($27)
- jsr $18,($27)
- jsr $18,($27)
- jsr $18,($27)
- jsr $18,($27)
-
- jsr $18,($27)
- jsr $18,($27)
- jsr $18,($27)
- jsr $18,($27)
- jsr $18,($27)
-
- subq $16,1,$16
- bgt $16,$L0
-
- ret $31,($26),1
- .end
-
-
- .ent b_call_imm
-b_call_imm:
-$L1:
- jsr $18,b_null
- jsr $18,b_null
- jsr $18,b_null
- jsr $18,b_null
- jsr $18,b_null
-
- jsr $18,b_null
- jsr $18,b_null
- jsr $18,b_null
- jsr $18,b_null
- jsr $18,b_null
-
- subq $16,1,$16
- bgt $16,$L1
-
- ret $31,($26),1
- .end
-
-
- .ent b_add
-b_add:
-$L2:
- addq $31,$31,$31
- addq $31,$31,$31
- addq $31,$31,$31
- addq $31,$31,$31
- addq $31,$31,$31
-
- addq $31,$31,$31
- addq $31,$31,$31
- addq $31,$31,$31
- addq $31,$31,$31
- addq $31,$31,$31
-
- subq $16,1,$16
- bgt $16,$L2
-
- ret $31,($26),1
- .end
-
-
- .ent b_load
-b_load:
-$L3:
- ldq $31,0($30)
- ldq $31,8($30)
- ldq $31,16($30)
- ldq $31,24($30)
- ldq $31,32($30)
-
- ldq $31,0($30)
- ldq $31,8($30)
- ldq $31,16($30)
- ldq $31,24($30)
- ldq $31,32($30)
-
- subq $16,1,$16
- bgt $16,$L3
-
- ret $31,($26),1
- .end
+++ /dev/null
-
-#
-# `Normal' configuration.
-#
-CC = gcc -ansi -Wall -pedantic
-
+++ /dev/null
-# This file (cnx_spp.Makefile) is part of the port of QuickThreads for
-# PA-RISC 1.1 architecture on a Convex SPP. This file is a machine dependent
-# makefile for QuickThreads. It was written in 1994 by Uwe Reder
-# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
-# Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
-
-# `Normal' configuration.
-
-CC = /usr/convex/bin/cc
+++ /dev/null
-# This file (pa-risc.Makefile) is part of the port of QuickThreads for
-# PA-RISC 1.1 architecture. This file is a machine dependent makefile
-# for QuickThreads. It was written in 1994 by Uwe Reder
-# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
-# Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
-
-# `Normal' configuration.
-
-CC = cc -Aa
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-/*
- * This file (pa-risc.h) is part of the port of QuickThreads for the
- * PA-RISC 1.1 architecture. This file is a machine dependent header
- * file. It was written in 1994 by Uwe Reder
- * (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
- * Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
- */
-
-
-#ifndef QT_PA_RISC_H
-#define QT_PA_RISC_H
-
-#include <qt.h>
-
-/* size of an integer-register (32 bit) */
-typedef unsigned long qt_word_t;
-
-/* PA-RISC's stack grows up */
-#define QT_GROW_UP
-
-/* Stack layout on PA-RISC according to PA-RISC Procedure Calling Conventions:
-
- Callee-save registers are: gr3-gr18, fr12-fr21.
- Also save gr2, return pointer.
-
- +---
- | fr12 Each floating register is a double word (8 bytes).
- | fr13 Floating registers are only saved if `qt_block' is
- | fr14 called, in which case it saves the floating-point
- | fr15 registers then calls `qt_blocki' to save the integer
- | fr16 registers.
- | fr17
- | fr18
- | fr19
- | fr20
- | fr21
- | <arg word 3> fixed arguments (must be allocated; may remain unused)
- | <arg word 2>
- | <arg word 1>
- | <arg word 0>
- | <LPT> frame marker
- | <LPT'>
- | <RP'>
- | <Current RP>
- | <Static Link>
- | <Clean Up>
- | <RP''>
- | <Previous SP>
- +---
- | gr3 word each (4 bytes)
- | gr4
- | gr5
- | gr6
- | gr7
- | gr8
- | gr9
- | gr10
- | gr11
- | gr12
- | gr13
- | gr14
- | gr15
- | gr16
- | gr17
- | gr18
- | <16 bytes filled in (sp has to be 64-bytes aligned)>
- | <arg word 3> fixed arguments (must be allocated; may remain unused)
- | <arg word 2>
- | <arg word 1>
- | <arg word 0>
- | <LPT> frame marker
- | <LPT'>
- | <RP'>
- | <Current RP>
- | <Static Link>
- | <Clean Up>
- | <RP''>
- | <Previous SP>
- +--- <--- sp
-*/
-
-/* When a never-before-run thread is restored, the return pc points
- to a fragment of code that starts the thread running. For
- non-vargs functions, it just calls the client's `only' function.
- For varargs functions, it calls the startup, user, and cleanup
- functions. */
-
-/* Note: Procedue Labels on PA-RISC
-
- <--2--><-------28---------><1-><1->
- -----------------------------------
- | SID | Adress Part | L | X |
- -----------------------------------
-
- On HP-UX the L field is used to flag wheather the procedure
- label (plabel) is a pointer to an LT entry or to the entry point
- of the procedure (PA-RISC Procedure Calling Conventions Reference
- Manual, 5.3.2 Procedure Labels and Dynamic Calls). */
-
-#define QT_PA_RISC_READ_PLABEL(plabel) \
- ( (((int)plabel) & 2) ? \
- ( (*((int *)(((int)plabel) & 0xfffffffc)))) : ((int)plabel) )
-
-/* Stack must be 64 bytes aligned. */
-#define QT_STKALIGN (64)
-
-/* Internal helper for putting stuff on stack (negative index!). */
-#define QT_SPUT(top, at, val) \
- (((qt_word_t *)(top))[-(at)] = (qt_word_t)(val))
-
-/* Offsets of various registers which are modified on the stack.
- rp (return-pointer) has to be stored in the frame-marker-area
- of the "older" stack-segment. */
-
-#define QT_crp (12+4+16+5)
-#define QT_15 (12+4+4)
-#define QT_16 (12+4+3)
-#define QT_17 (12+4+2)
-#define QT_18 (12+4+1)
-
-
-/** This stuff is for NON-VARARGS. **/
-
-/* Stack looks like this (2 stack frames):
-
- <--- 64-bytes aligned --><------- 64-bytes aligned ------------>
- | || |
- <--16--><------48-------><----16*4-----><--16-><------48------->
- || | || | | ||
- ||filler|arg|frame-marker||register-save|filler|arg|frame-marker||
- ------------------------------------------------------------------
- */
-
-#define QT_STKBASE (16+48+(16*sizeof(qt_word_t))+16+48)
-
-/* The index, relative to sp, of where to put each value. */
-#define QT_ONLY_INDEX (QT_15)
-#define QT_USER_INDEX (QT_16)
-#define QT_ARGT_INDEX (QT_17)
-#define QT_ARGU_INDEX (QT_18)
-
-extern void qt_start(void);
-#define QT_ARGS_MD(sp) \
- (QT_SPUT (sp, QT_crp, QT_PA_RISC_READ_PLABEL(qt_start)))
-
-
-/** This is for VARARGS. **/
-
-#define QT_VARGS_DEFAULT
-
-/* Stack looks like this (2 stack frames):
-
- <------ 64-bytes aligned -------><--------- 64-bytes aligned ---------->
- | || |
- <---?--><--?---><16><----32-----><----16*4-----><-16--><16><----32----->
- || | | | || | | | ||
- ||filler|varargs|arg|frame-marker||register-save|filler|arg|frame-marker||
- --------------------------------------------------------------------------
- */
-
-/* Sp is moved to the end of the first stack frame. */
-#define QT_VARGS_MD0(sp, vasize) \
- ((qt_t *)(((char *)sp) + QT_STKROUNDUP(vasize + 4*4 + 32)))
-
-/* To reach the arguments from the end of the first stack frame use 32
- as a negative adjustment. */
-#define QT_VARGS_ADJUST(sp) ((qt_t *)(((char *)sp) - 32))
-
-/* Offset to reach the end of the second stack frame. */
-#define QT_VSTKBASE ((16*sizeof(qt_word_t)) + 16 + 4*4 + 32)
-
-extern void qt_vstart(void);
-#define QT_VARGS_MD1(sp) \
- (QT_SPUT (sp, QT_crp, QT_PA_RISC_READ_PLABEL(qt_vstart)))
-
-#define QT_VARGT_INDEX (QT_15)
-#define QT_VSTARTUP_INDEX (QT_16)
-#define QT_VUSERF_INDEX (QT_17)
-#define QT_VCLEANUP_INDEX (QT_18)
-
-#endif /* ndef QT_PA_RISC_H */
+++ /dev/null
-; pa-risc.s -- assembly support.
-
-; QuickThreads -- Threads-building toolkit.
-; Copyright (c) 1993 by David Keppel
-;
-; Permission to use, copy, modify and distribute this software and
-; its documentation for any purpose and without fee is hereby
-; granted, provided that the above copyright notice and this notice
-; appear in all copies. This software is provided as a
-; proof-of-concept and for demonstration purposes; there is no
-; representation about the suitability of this software for any
-; purpose.
-
-; This file (pa-risc.s) is part of the port of QuickThreads for
-; PA-RISC 1.1 architecture. This file implements context switches
-; and thread startup. It was written in 1994 by Uwe Reder
-; (`uereder@cip.informatik.uni-erlangen.de') for the Operating
-; Systems Department (IMMD4) at the University of Erlangen/Nuernberg
-; Germany.
-
-
-; Callee saves general registers gr3..gr18,
-; floating-point registers fr12..fr21.
-
- .CODE
-
- .IMPORT $$dyncall, MILLICODE
- .IMPORT qt_error, CODE
-
- .EXPORT qt_blocki, ENTRY
- .EXPORT qt_block, ENTRY
- .EXPORT qt_abort, ENTRY
- .EXPORT qt_start, ENTRY
- .EXPORT qt_vstart, ENTRY
-
-
-; arg0: ptr to function (helper) to call once curr is suspended
-; and control is on arg3's stack.
-; arg1: 1'th arg to *arg0.
-; arg2: 2'th arg to *arg0.
-; arg3: sp of new thread.
-
-qt_blocki
- .PROC
- .CALLINFO CALLER, FRAME=0, SAVE_RP, ENTRY_GR=18
- .ENTRY
-
- stw %rp,-20(%sp) ; save rp to old frame-marker
-
- stwm %r3,128(%sp) ; save callee-saves general registers
- stw %r4,-124(%sp)
- stw %r5,-120(%sp)
- stw %r6,-116(%sp)
- stw %r7,-112(%sp)
- stw %r8,-108(%sp)
- stw %r9,-104(%sp)
- stw %r10,-100(%sp)
- stw %r11,-96(%sp)
- stw %r12,-92(%sp)
- stw %r13,-88(%sp)
- stw %r14,-84(%sp)
- stw %r15,-80(%sp)
- stw %r16,-76(%sp)
- stw %r17,-72(%sp)
- stw %r18,-68(%sp)
-
-qt_abort
- copy %arg0,%r22 ; helper to be called by $$dyncall
- copy %sp,%arg0 ; pass current sp as arg0 to helper
- copy %arg3,%sp ; set new sp
-
- .CALL
- bl $$dyncall,%mrp ; call helper
- copy %mrp,%rp
-
- ldw -68(%sp),%r18 ; restore general registers
- ldw -72(%sp),%r17
- ldw -76(%sp),%r16
- ldw -80(%sp),%r15
- ldw -84(%sp),%r14
- ldw -88(%sp),%r13
- ldw -92(%sp),%r12
- ldw -96(%sp),%r11
- ldw -100(%sp),%r10
- ldw -104(%sp),%r9
- ldw -108(%sp),%r8
- ldw -112(%sp),%r7
- ldw -116(%sp),%r6
- ldw -120(%sp),%r5
- ldw -124(%sp),%r4
-
- ldw -148(%sp),%rp ; restore return-pointer
-
- bv %r0(%rp) ; return to caller
- ldwm -128(%sp),%r3
-
- .EXIT
- .PROCEND
-
-
-qt_block
- .PROC
- .CALLINFO CALLER, FRAME=0, SAVE_RP, ENTRY_FR=21
- .ENTRY
-
- stw %rp,-20(%sp) ; save rp to old frame-marker
-
- fstds,ma %fr12,8(%sp) ; save callee-saves float registers
- fstds,ma %fr13,8(%sp)
- fstds,ma %fr14,8(%sp)
- fstds,ma %fr15,8(%sp)
- fstds,ma %fr16,8(%sp)
- fstds,ma %fr17,8(%sp)
- fstds,ma %fr18,8(%sp)
- fstds,ma %fr19,8(%sp)
- fstds,ma %fr20,8(%sp)
- fstds,ma %fr21,8(%sp)
-
- .CALL
- bl qt_blocki,%rp
- ldo 48(%sp),%sp
-
- ldo -48(%sp),%sp
-
- fldds,mb -8(%sp),%fr21 ; restore callee-saves float registers
- fldds,mb -8(%sp),%fr20
- fldds,mb -8(%sp),%fr19
- fldds,mb -8(%sp),%fr18
- fldds,mb -8(%sp),%fr17
- fldds,mb -8(%sp),%fr16
- fldds,mb -8(%sp),%fr15
- fldds,mb -8(%sp),%fr14
- fldds,mb -8(%sp),%fr13
-
- ldw -28(%sp),%rp ; restore return-pointer
-
- bv %r0(%rp) ; return to caller.
- fldds,mb -8(%sp),%fr12
-
- .EXIT
- .PROCEND
-
-
-qt_start
- .PROC
- .CALLINFO CALLER, FRAME=0
- .ENTRY
-
- copy %r18,%arg0 ; set user arg `pu'.
- copy %r17,%arg1 ; ... user function pt.
- copy %r16,%arg2 ; ... user function userf.
- ; %r22 is a caller-saves register
- copy %r15,%r22 ; function to be called by $$dyncall
-
- .CALL ; in=%r22
- bl $$dyncall,%mrp ; call `only'.
- copy %mrp,%rp
-
- bl,n qt_error,%r0 ; `only' erroniously returned.
-
- .EXIT
- .PROCEND
-
-
-; Varargs
-;
-; First, call `startup' with the `pt' argument.
-;
-; Next, call the user's function with all arguments.
-; We don't know whether arguments are integers, 32-bit floating-points or
-; even 64-bit floating-points, so we reload all the registers, possibly
-; with garbage arguments. The thread creator provided non-garbage for
-; the arguments that the callee actually uses, so the callee never gets
-; garbage.
-;
-; -48 -44 -40 -36 -32
-; | arg3 | arg2 | arg1 | arg0 |
-; -----------------------------
-; integers: arg3 arg2 arg1 arg0
-; 32-bit fps: farg3 farg2 farg1 farg0
-; 64-bit fps: <---farg3--> <---farg1-->
-;
-; Finally, call `cleanup' with the `pt' argument and with the return value
-; from the user's function. It is an error for `cleanup' to return.
-
-qt_vstart
- .PROC
- .CALLINFO CALLER, FRAME=0
- .ENTRY
-
- ; Because the startup function may damage the fixed arguments
- ; on the stack (PA-RISC Procedure Calling Conventions Reference
- ; Manual, 2.4 Fixed Arguments Area), we allocate a seperate
- ; stack frame for it.
- ldo 64(%sp),%sp
-
- ; call: void startup(void *pt)
-
- copy %r15,%arg0 ; `pt' is arg0 to `startup'.
- copy %r16,%r22
- .CALL
- bl $$dyncall,%mrp ; Call `startup'.
- copy %mrp,%rp
-
- ldo -64(%sp),%sp
-
- ; call: void *qt_vuserf_t(...)
-
- ldw -36(%sp),%arg0 ; Load args to integer registers.
- ldw -40(%sp),%arg1
- ldw -44(%sp),%arg2
- ldw -48(%sp),%arg3
- ; Index of fld[w|d]s only ranges from -16 to 15, so we
- ; take r22 to be our new base register.
- ldo -32(%sp),%r22
- fldws -4(%r22),%farg0 ; Load args to floating-point registers.
- fldds -8(%r22),%farg1
- fldws -12(%r22),%farg2
- fldds -16(%r22),%farg3
- copy %r17,%r22
- .CALL
- bl $$dyncall,%mrp ; Call `userf'.
- copy %mrp,%rp
-
- ; call: void cleanup(void *pt, void *vuserf_return)
-
- copy %r15,%arg0 ; `pt' is arg0 to `cleanup'.
- copy %ret0,%arg1 ; Return-value is arg1 to `cleanup'.
- copy %r18,%r22
- .CALL
- bl $$dyncall,%mrp ; Call `cleanup'.
- copy %mrp,%rp
-
- bl,n qt_error,%r0
-
- .EXIT
- .PROCEND
+++ /dev/null
-; QuickThreads -- Threads-building toolkit.
-; Copyright (c) 1993 by David Keppel
-
-; Permission to use, copy, modify and distribute this software and
-; its documentation for any purpose and without fee is hereby
-; granted, provided that the above copyright notice and this notice
-; appear in all copies. This software is provided as a
-; proof-of-concept and for demonstration purposes; there is no
-; representation about the suitability of this software for any
-; purpose.
-
-; This file (pa-risc_b.s) is part of the port of QuickThreads for
-; PA-RISC 1.1 architecture. It contains assembly-level support for
-; raw processor performance measurement. It was written in 1994 by
-; Uwe Reder (`uereder@cip.informatik.uni-erlangen.de')
-; for the Operating Systems Department (IMMD4) at the
-; University of Erlangen/Nuernberg Germany.
-
-
-; Note that the number of instructions in the measurement-loops, differ
-; from implementation to implementation. I took eight instructions in a loop
-; for every test (execute eight instructions and loop to the start).
-
- .CODE
-
- .IMPORT $global$,DATA
- .IMPORT $$dyncall,MILLICODE
- .EXPORT b_call_reg
- .EXPORT b_call_imm
- .EXPORT b_add
- .EXPORT b_load
-
-; Just do nothing, only return to caller. This procedure is called by
-; `b_call_reg' and `b_call_imm'.
-
-b_null
- .PROC
- .CALLINFO NO_CALLS, FRAME=0
- .ENTRY
-
- bv,n %r0(%rp) ; just return
-
- .EXIT
- .PROCEND
-
-; Call the procedure `b_null' with function pointer in a register.
-
-b_call_reg
- .PROC
- .CALLINFO CALLER, FRAME=0
- .ENTRY
-
- stwm %r3,64(%sp) ; store r3 (may be used by caller)
- stw %rp,-20(%sp) ; save return-pointer to frame-marker
-
- addil LR'to_call-$global$,%r27
- ldw RR'to_call-$global$(%r1),%r3
-
-_loop0
- copy %r3,%r22 ; copy the procedure label to r22, ...
- .CALL ; ...this is the input to $$dyncall
- bl $$dyncall,%mrp ; call $$dyncall (millicode function)
- copy %mrp,%rp ; remember the return-pointer
-
- copy %r3,%r22
- .CALL
- bl $$dyncall,%mrp
- copy %mrp,%rp
-
- copy %r3,%r22
- .CALL
- bl $$dyncall,%mrp
- copy %mrp,%rp
-
- copy %r3,%r22
- .CALL
- bl $$dyncall,%mrp
- copy %mrp,%rp
-
- copy %r3,%r22
- .CALL
- bl $$dyncall,%mrp
- copy %mrp,%rp
-
- copy %r3,%r22
- .CALL
- bl $$dyncall,%mrp
- copy %mrp,%rp
-
- copy %r3,%r22
- .CALL
- bl $$dyncall,%mrp
- copy %mrp,%rp
-
- copy %r3,%r22
- .CALL
- bl $$dyncall,%mrp
- copy %mrp,%rp
-
- addibf,<= -8,%arg0,_loop0 ; decrement counter by 8 and loop
- nop
-
- ldw -20(%sp),%rp ; restore return-pointer
- bv %r0(%rp) ; return to caller
- ldwm -64(%sp),%r3 ; resore r3 and remove stack frame
-
- .EXIT
- .PROCEND
-
-; Call the procedure `b_null' immediate.
-
-b_call_imm
- .PROC
- .CALLINFO CALLER, FRAME=0, SAVE_RP
- .ENTRY
-
- ldo 64(%sp),%sp ; caller needs a stack-frame
- stw %rp,-20(%sp) ; save return-pointer to frame-marker
-
-_loop1
- bl b_null,%rp ; call `b_null' immediate (8 times)
- nop
- bl b_null,%rp
- nop
- bl b_null,%rp
- nop
- bl b_null,%rp
- nop
- bl b_null,%rp
- nop
- bl b_null,%rp
- nop
- bl b_null,%rp
- nop
- bl b_null,%rp
- nop
-
- addibf,<= -8,%arg0,_loop1 ; decrement counter by 8 and loop
- nop
-
- ldw -20(%sp),%rp ; restore return-pointer
- bv %r0(%rp) ; return to caller
- ldo -64(%sp),%sp ; remove stack-frame
-
- .EXIT
- .PROCEND
-
-; Copy register-to-register.
-; On PA-RISC this is implemented with an `or'.
-; The `or' is hidden by a pseudo-operation called `copy'.
-
-b_add
- .PROC
- .CALLINFO NO_CALLS, FRAME=0
- .ENTRY
-
-_loop2
- copy %r19,%r20 ; copy register-to-register
- copy %r20,%r21 ; use caller-saves registers
- copy %r21,%r22
- copy %r22,%r21
- copy %r21,%r20
- copy %r20,%r19
- copy %r19,%r20
- copy %r20,%r21
-
- addibf,<= -8,%arg0,_loop2 ; decrement counter by 8 and loop
- nop
-
- bv,n %r0(%rp)
-
- .EXIT
- .PROCEND
-
-; Load memory to a register.
-
-b_load
- .PROC
- .CALLINFO NO_CALLS, FRAME=0
- .ENTRY
-
-_loop3
- ldw -4(%sp),%r22 ; load data from frame-marker
- ldw -8(%sp),%r22 ; use a caller-saves register
- ldw -12(%sp),%r22
- ldw -16(%sp),%r22
- ldw -20(%sp),%r22
- ldw -24(%sp),%r22
- ldw -28(%sp),%r22
- ldw -32(%sp),%r22
-
- addibf,<= -8,%arg0,_loop3 ; decrement counter by 8 and loop
- nop
-
- bv,n %r0(%rp)
-
- .EXIT
- .PROCEND
-
-
- .ALIGN 8
-to_call
- .WORD b_null
+++ /dev/null
-Note that some machines want labels to have leading underscores,
-while others (e.g. System V) do not. Thus, several labels appear
-duplicated except for the leading underscore, e.g.
-
- _qt_cswap:
- qt_cswap:
-
+++ /dev/null
-;; i386.asm -- assembly support.
-
-;;
-;; QuickThreads -- Threads-building toolkit.
-;; Copyright (c) 2001, 2006 Free Software Foundation, Inc.
-;;
-;; Permission to use, copy, modify and distribute this software and
-;; its documentation for any purpose and without fee is hereby
-;; granted, provided that the above copyright notice and this notice
-;; appear in all copies. This software is provided as a
-;; proof-of-concept and for demonstration purposes; there is no
-;; representation about the suitability of this software for any
-;; purpose.
-
-;; NOTE: double-labeled `_name' and `name' for System V compatability.
-;; NOTE: Comment lines start like this one, or with '//' ONLY. Sorry!
-
-;; Callee-save: %esi, %edi, %ebx, %ebp
-;; Caller-save: %eax, %ecx
-;; Can't tell: %edx (seems to work w/o saving it.)
-;;
-;; Assignment:
-;;
-;; See ``i386.h'' for the somewhat unconventional stack layout.
-
-
- .386p
- .model flat
- .code
-
- public _qt_abort
- public qt_abort
- public _qt_block
- public qt_block
- public _qt_blocki
- public qt_blocki
-
-;; These all have the type signature
-;;
-;; void *blocking (helper, arg0, arg1, new)
-;;
-;; On procedure entry, the helper is at 4(sp), args at 8(sp) and
-;; 12(sp) and the new thread's sp at 16(sp). It *appears* that the
-;; calling convention for the 8X86 requires the caller to save all
-;; floating-point registers, this makes our life easy.
-
-;; Halt the currently-running thread. Save it's callee-save regs on
-;; to the stack, 32 bytes. Switch to the new stack (next == 16+32(sp))
-;; and call the user function (f == 4+32(sp) with arguments: old sp
-;; arg1 (8+32(sp)) and arg2 (12+32(sp)). When the user function is
-;; done, restore the new thread's state and return.
-;;
-;; `qt_abort' is (currently) an alias for `qt_block' because most of
-;; the work is shared. We could save the insns up to `qt_common' by
-;; replicating, but w/o replicating we need an inital subtract (to
-;; offset the stack as if it had been a qt_block) and then a jump
-;; to qt_common. For the cost of a jump, we might as well just do
-;; all the work.
-;;
-;; The helper function (4(sp)) can return a void* that is returned
-;; by the call to `qt_blockk{,i}'. Since we don't touch %eax in
-;; between, we get that ``for free''.
-
-_qt_abort:
-qt_abort:
-_qt_block:
-qt_block:
-_qt_blocki:
-qt_blocki:
- push ebp ; Save callee-save, sp-=4.
- push esi ; Save callee-save, sp-=4.
- push edi ; Save callee-save, sp-=4.
- push ebx ; Save callee-save, sp-=4.
- mov eax, esp ; Remember old stack pointer.
-
-qt_common:
- mov esp, [esp+32] ; Move to new thread.
- push [eax+28] ; Push arg 2.
- push [eax+24] ; Push arg 1.
- push eax ; Push arg 0.
- mov ebx, [eax+20] ; Get function to call.
- call ebx ; Call f.
- add esp, 12 ; Pop args.
-
- pop ebx ; Restore callee-save, sp+=4.
- pop edi ; Restore callee-save, sp+=4.
- pop esi ; Restore callee-save, sp+=4.
- pop ebp ; Restore callee-save, sp+=4.
- ret ; Resume the stopped function.
- hlt
-
-
-;; Start a varargs thread.
-
- public _qt_vstart
- public qt_vstart
-
-_qt_vstart:
-qt_vstart:
- push edi ; Push `pt' arg to `startup'.
- call ebp ; Call `startup'.
- pop eax ; Clean up the stack.
-
- call ebx ; Call the user's function.
-
- push eax ; Push return from user's.
- push edi ; Push `pt' arg to `cleanup'.
- call esi ; Call `cleanup'.
-
- hlt ; `cleanup' never returns.
-
- end
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#ifndef QT_386_H
-#define QT_386_H
-
-typedef unsigned long qt_word_t;
-
-/* Thread's initial stack layout on the i386:
-
- non-varargs:
-
- +---
- | arg[2] === `userf' on startup
- | arg[1] === `pt' on startup
- | arg[0] === `pu' on startup
- +---
- | ret pc === qt_error
- +---
- | ret pc === `only' on startup
- +---
- | %ebp
- | %esi
- | %edi
- | %ebx <--- qt_t.sp
- +---
-
- When a non-varargs thread is started, it ``returns'' directly to
- the client's `only' function.
-
- varargs:
-
- +---
- | arg[n-1]
- | ..
- | arg[0]
- +---
- | ret pc === `qt_vstart'
- +---
- | %ebp === `startup'
- | %esi === `cleanup'
- | %edi === `pt'
- | %ebx === `vuserf' <--- qt_t.sp
- +---
-
- When a varargs thread is started, it ``returns'' to the `qt_vstart'
- startup code. The startup code calls the appropriate functions. */
-
-
-/* What to do to start a varargs thread running. */
-QT_API void qt_vstart (void);
-
-
-/* Hold 4 saved regs plus two return pcs (qt_error, qt_start) plus
- three args. */
-#define QT_STKBASE (9 * 4)
-
-/* Hold 4 saved regs plus one return pc (qt_vstart). */
-#define QT_VSTKBASE (5 * 4)
-
-
-/* Stack must be 4-byte aligned. */
-#define QT_STKALIGN (4)
-
-
-/* Where to place various arguments. */
-#define QT_ONLY_INDEX (QT_PC)
-#define QT_USER_INDEX (QT_ARG2)
-#define QT_ARGT_INDEX (QT_ARG1)
-#define QT_ARGU_INDEX (QT_ARG0)
-
-#define QT_VSTARTUP_INDEX (QT_EBP)
-#define QT_VUSERF_INDEX (QT_EBX)
-#define QT_VCLEANUP_INDEX (QT_ESI)
-#define QT_VARGT_INDEX (QT_EDI)
-
-
-#define QT_EBX 0
-#define QT_EDI 1
-#define QT_ESI 2
-#define QT_EBP 3
-#define QT_PC 4
-/* The following are defined only for non-varargs. */
-#define QT_RPC 5
-#define QT_ARG0 6
-#define QT_ARG1 7
-#define QT_ARG2 8
-
-
-/* Stack grows down. The top of the stack is the first thing to
- pop off (preincrement, postdecrement). */
-#define QT_GROW_DOWN
-
-QT_API void qt_error (void);
-
-/* Push on the error return address. */
-#define QT_ARGS_MD(sto) \
- (QT_SPUT (sto, QT_RPC, qt_error))
-
-
-/* When varargs are pushed, allocate space for all the args. */
-#define QT_VARGS_MD0(sto, nbytes) \
- ((qt_t *)(((char *)(sto)) - QT_STKROUNDUP(nbytes)))
-
-#define QT_VARGS_MD1(sto) \
- (QT_SPUT (sto, QT_PC, qt_vstart))
-
-#define QT_VARGS_DEFAULT
-
-#endif /* QT_386_H */
+++ /dev/null
-/* i386.s -- assembly support. */
-
-/*
-// QuickThreads -- Threads-building toolkit.
-// Copyright (c) 1993 by David Keppel
-//
-// Permission to use, copy, modify and distribute this software and
-// its documentation for any purpose and without fee is hereby
-// granted, provided that the above copyright notice and this notice
-// appear in all copies. This software is provided as a
-// proof-of-concept and for demonstration purposes; there is no
-// representation about the suitability of this software for any
-// purpose. */
-
-/* NOTE: double-labeled `_name' and `name' for System V compatability. */
-/* NOTE: Comment lines start like this one, or with '//' ONLY. Sorry! */
-
-/* Callee-save: %esi, %edi, %ebx, %ebp
-// Caller-save: %eax, %ecx
-// Can't tell: %edx (seems to work w/o saving it.)
-//
-// Assignment:
-//
-// See ``i386.h'' for the somewhat unconventional stack layout. */
-
-
- .text
- .align 2
-
- .globl _qt_abort
- .globl qt_abort
- .globl _qt_block
- .globl qt_block
- .globl _qt_blocki
- .globl qt_blocki
-
-/* These all have the type signature
-//
-// void *blocking (helper, arg0, arg1, new)
-//
-// On procedure entry, the helper is at 4(sp), args at 8(sp) and
-// 12(sp) and the new thread's sp at 16(sp). It *appears* that the
-// calling convention for the 8X86 requires the caller to save all
-// floating-point registers, this makes our life easy. */
-
-/* Halt the currently-running thread. Save it's callee-save regs on
-// to the stack, 32 bytes. Switch to the new stack (next == 16+32(sp))
-// and call the user function (f == 4+32(sp) with arguments: old sp
-// arg1 (8+32(sp)) and arg2 (12+32(sp)). When the user function is
-// done, restore the new thread's state and return.
-//
-// `qt_abort' is (currently) an alias for `qt_block' because most of
-// the work is shared. We could save the insns up to `qt_common' by
-// replicating, but w/o replicating we need an inital subtract (to
-// offset the stack as if it had been a qt_block) and then a jump
-// to qt_common. For the cost of a jump, we might as well just do
-// all the work.
-//
-// The helper function (4(sp)) can return a void* that is returned
-// by the call to `qt_blockk{,i}'. Since we don't touch %eax in
-// between, we get that ``for free''. */
-
-_qt_abort:
-qt_abort:
-_qt_block:
-qt_block:
-_qt_blocki:
-qt_blocki:
- pushl %ebp /* Save callee-save, sp-=4. */
- pushl %esi /* Save callee-save, sp-=4. */
- pushl %edi /* Save callee-save, sp-=4. */
- pushl %ebx /* Save callee-save, sp-=4. */
- movl %esp, %eax /* Remember old stack pointer. */
-
-qt_common:
- movl 32(%esp), %esp /* Move to new thread. */
- pushl 28(%eax) /* Push arg 2. */
- pushl 24(%eax) /* Push arg 1. */
- pushl %eax /* Push arg 0. */
- movl 20(%eax), %ebx /* Get function to call. */
- call *%ebx /* Call f. */
- addl $12, %esp /* Pop args. */
-
- popl %ebx /* Restore callee-save, sp+=4. */
- popl %edi /* Restore callee-save, sp+=4. */
- popl %esi /* Restore callee-save, sp+=4. */
- popl %ebp /* Restore callee-save, sp+=4. */
- ret /* Resume the stopped function. */
- hlt
-
-
-/* Start a varargs thread. */
-
- .globl _qt_vstart
- .globl qt_vstart
-_qt_vstart:
-qt_vstart:
- pushl %edi /* Push `pt' arg to `startup'. */
- call *%ebp /* Call `startup'. */
- popl %eax /* Clean up the stack. */
-
- call *%ebx /* Call the user's function. */
-
- pushl %eax /* Push return from user's. */
- pushl %edi /* Push `pt' arg to `cleanup'. */
- call *%esi /* Call `cleanup'. */
-
- hlt /* `cleanup' never returns. */
+++ /dev/null
-/*
-// QuickThreads -- Threads-building toolkit.
-// Copyright (c) 1993 by David Keppel
-//
-// Permission to use, copy, modify and distribute this software and
-// its documentation for any purpose and without fee is hereby
-// granted, provided that the above copyright notice and this notice
-// appear in all copies. This software is provided as a
-// proof-of-concept and for demonstration purposes; there is no
-// representation about the suitability of this software for any
-// purpose. */
-
- .globl _b_call_reg
- .globl b_call_reg
- .globl _b_call_imm
- .globl b_call_imm
- .globl _b_add
- .globl b_add
- .globl _b_load
- .globl b_load
-
-_b_call_reg:
-b_call_reg:
-_b_call_imm:
-b_call_imm:
-_b_add:
-b_add:
-_b_load:
-b_load:
- hlt
+++ /dev/null
-
-#
-# KSR1 configuration.
-#
-CC = cc -ansi
-
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#ifndef QT_KSR1_H
-#define QT_KSR1_H
-
-/*
- Stack layout:
-
- Registers are saved in strictly low to high order, FPU regs first
- (only if qt_block is called), CEU regs second, IPU regs next, with no
- padding between the groups.
-
- Callee-save: f16..f63; c15..c30; i12..i30.
- Args passed in i2..i5.
-
- Note: c31 is a private data pointer. It is not changed on thread
- swaps with the assumption that it represents per-processor rather
- than per-thread state.
-
- Note: i31 is an instruction count register that is updated by the
- context switch routines. Like c31, it is not changed on context
- switches.
-
- This is what we want on startup:
-
-
- +------ <-- BOS: Bottom of stack (grows down)
- | 80 (128 - 48) bytes of padding to a 128-byte boundary
- +---
- | only
- | userf
- | t
- | u
- | qt_start$TXT
- | (empty) <-- qt.sp
- +------ <-- (BOS - 128)
-
- This is why we want this on startup:
-
- A thread begins running when the restore procedure switches thread stacks
- and pops a return address off of the top of the new stack (see below
- for the reason why we explicitly store qt_start$TXT). The
- block procedure pushes two jump addresses on a thread's stack before
- it switches stacks. The first is the return address for the block
- procedure, and the second is a restore address. The return address
- is used to jump back to the thread that has been switched to; the
- restore address is a jump within the block code to restore the registers.
- Normally, this is just a jump to the next address. However, on thread
- startup, this is a jump to qt_start$TXT. (The block procedure stores
- the restore address at an offset of 8 bytes from the top of the stack,
- which is also the offset at which qt_start$TXT is stored on the stacks
- of new threads. Hence, when the block procedure switches to a new
- thread stack, it will initially jump to qt_start$TXT; thereafter,
- it jumps to the restore code.)
-
- qt_start$TXT, after it has read the initial data on the new thread's
- stack and placed it in registers, pops the initial stack frame
- and gives the thread the entire stack to use for execution.
-
- The KSR runtime system has an unusual treatment of pointers to
- functions. From C, taking the `name' of a function yields a
- pointer to a _constant block_ and *not* the address of the
- function. The zero'th entry in the constant block is a pointer to
- the function.
-
- We have to be careful: the restore procedure expects a return
- address on the top of the stack (pointed to by qt.sp). This is not
- a problem when restoring a thread that has run before, since the
- block routine would have stored the return address on top of the
- stack. However, when ``faking up'' a thread start (bootstrapping a
- thread stack frame), the top of the stack needs to contain a
- pointer to the code that will start the thread running.
-
- The pointer to the startup code is *not* `qt_start'. It is the
- word *pointed to* by `qt_start'. Thus, we dereference `qt_start',
- see QT_ARGS_MD below.
-
- On varargs startup (still unimplemented):
-
- | padding to 128 byte boundary
- | varargs <-- padded to a 128-byte-boundary
- +---
- | caller's frame, 16 bytes
- | 80 bytes of padding (frame padded to a 128-byte boundary)
- +---
- | cleanup
- | vuserf
- | startup
- | t
- +---
- | qt_start <-- qt.sp
- +---
-
- Of a suspended thread:
-
- +---
- | caller's frame, 16 bytes
- | fpu registers 47 regs * 8 bytes/reg 376 bytes
- | ceu registers 16 regs * 8 bytes/reg 128 bytes
- | ipu registers 19 regs * 8 bytes/reg 152 bytes
- | :
- | 80 bytes of padding
- | :
- | qt_restore <-- qt.sp
- +---
-
- */
-
-
-#define QT_STKALIGN 128
-#define QT_GROW_DOWN
-typedef unsigned long qt_word_t;
-
-#define QT_STKBASE QT_STKALIGN
-#define QT_VSTKBASE QT_STKBASE
-
-extern void qt_start(void);
-/*
- * See the discussion above for what indexing into a procedure ptr
- * does for us (it's lovely, though, isn't it?).
- *
- * This assumes that the address of a procedure's code is the
- * first word in a procedure's constant block. That's how the manual
- * says it will be arranged.
- */
-#define QT_ARGS_MD(sp) (QT_SPUT (sp, 1, ((qt_word_t *)qt_start)[0]))
-
-/*
- * The *index* (positive offset) of where to put each value.
- * See the picture of the stack above that explains the offsets.
- */
-#define QT_ONLY_INDEX (5)
-#define QT_USER_INDEX (4)
-#define QT_ARGT_INDEX (3)
-#define QT_ARGU_INDEX (2)
-
-#define QT_VARGS_DEFAULT
-#define QT_VARGS(sp, nb, vargs, pt, startup, vuserf, cleanup) \
- (qt_vargs (sp, nbytes, &vargs, pt, startup, vuserf, cleanup))
-
-
-#define QT_VARGS_MD0(sp, vabytes) \
- ((qt_t *)(((char *)(sp)) - 4*8 - QT_STKROUNDUP(vabytes)))
-
-extern void qt_vstart(void);
-#define QT_VARGS_MD1(sp) (QT_SPUT (sp, 0, ((qt_word_t *)qt_vstart)[0]))
-
-#define QT_VCLEANUP_INDEX (4)
-#define QT_VUSERF_INDEX (3)
-#define QT_VSTARTUP_INDEX (2)
-#define QT_VARGT_INDEX (1)
-
-#endif /* def QT_KSR1_H */
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
- .file "ksr1.s"
- .def .debug; .endef
-
- .align 128
- .globl qt_blocki
- .globl qt_blocki$TXT
- .globl qt_block
- .globl qt_block$TXT
- .globl qt_start$TXT
- .globl qt_start
- .globl qt_abort$TXT
- .globl qt_abort
- .globl qt_vstart
- .globl qt_vstart$TXT
-
-#
-# KSR convention: on procedure calls, load both the procedure address
-# and a pointer to a constant block. The address of function `f' is
-# `f$TXT', and the constant block address is `f'. The constant block
-# has several reserved values:
-#
-# 8 bytes fpu register save mask
-# 4 bytes ipu register save mask
-# 4 bytes ceu register save mask
-# f: f$TXT
-# ... whatever you want ... (not quite...read on)
-#
-# Note, by the way, that a pointer to a function is passed as a
-# pointer to the constant area, and the constant area has the text
-# address.
-#
-
-#
-# Procedures that do not return structures prefix their code with
-#
-# proc$TXT:
-# finop; cxnop
-# finop; cxnop
-# <proc code>
-#
-# Calls to those procedures branch to a 16 byte offset (4 instrs) in
-# to the procedure to skip those instructions.
-#
-# Procedures that return structures use a different code prefix:
-#
-# proc$TXT:
-# finop; beq.qt %rc, %rc, 24 # return value entry
-# finop; cxnop
-# finop; movi8 0, %rc # no return value entry
-# <proc code>
-#
-# Calls that want the returned structure branch directly to the
-# procedure address. Callers that don't want (or aren't expecting) a
-# return value branche 16 bytes in to the procedure, which will zero
-# %rc, telling the called procedure not to return a structure.
-#
-
-#
-# On entry:
-# %i2 -- control block of helper function to run
-# (dereference to get helper)
-# %i3 -- a1
-# %i4 -- a2
-# %i5 -- sp of new to run
-#
-
- .data
- .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
-qt_blocki:
-qt_abort:
- .word qt_blocki$TXT
- .word qt_restore$TXT
-
- .text
-qt_abort$TXT:
-qt_blocki$TXT:
- finop ; cxnop # entry prefix
- finop ; cxnop # entry prefix
- add8.ntr 75,%i31,%i31 ; movi8 512,%c5 # ICR; stk adjust
- finop ; ssub8.ntr 0,%sp,%c5,%sp
- finop ; st8 %fp,504(%sp) # Save caller's fp
- finop ; st8 %cp,496(%sp) # Save caller's cp
- finop ; ld8 8(%c10),%c5 # ld qt_restore$TXT
- finop ; st8 %c14,0(%sp) # Save special ret addr
- finop ; mov8_8 %c10, %cp # Our cp
- finop ; sadd8.ntr 0,%sp,%c5,%fp # Our frame ptr
- finop ; st8 %c5,8(%sp) # st qt_restore$TXT
-#
-# CEU registers %c15-%c24, %c26-%c30 (%c14 we restore later)
-#
- finop ; st8 %c15,456(%sp)
- finop ; st8 %c16,448(%sp)
- finop ; st8 %c17,440(%sp)
- finop ; st8 %c18,432(%sp)
- finop ; st8 %c19,424(%sp)
- finop ; st8 %c20,416(%sp)
- finop ; st8 %c21,408(%sp)
- finop ; st8 %c22,400(%sp)
- finop ; st8 %c23,392(%sp)
- finop ; st8 %c24,384(%sp)
-#
-# %c25 is the Enclosing Frame Pointer (EFP) -- since C doesn't
-# use nested procedures, we ignore it (leaving a gap, though)
-#
- finop ; st8 %c26,368(%sp)
- finop ; st8 %c27,360(%sp)
- finop ; st8 %c28,352(%sp)
- finop ; st8 %c29,344(%sp)
- finop ; st8 %c30,336(%sp)
-#
-# IPU registers %i12-%i30
-#
- finop ; st8 %i12,328(%sp)
- finop ; st8 %i13,320(%sp)
- finop ; st8 %i14,312(%sp)
- finop ; st8 %i15,304(%sp)
-# (gap to get alignment for st64)
-# -- Doesn't work on version 1.1.3 of the OS
-# finop ; st64 %i16,256(%sp)
-
- finop ; st8 %i16,256(%sp)
- finop ; st8 %i17,248(%sp)
- finop ; st8 %i18,240(%sp)
- finop ; st8 %i19,232(%sp)
- finop ; st8 %i20,224(%sp)
- finop ; st8 %i21,216(%sp)
- finop ; st8 %i22,208(%sp)
- finop ; st8 %i23,200(%sp)
- finop ; st8 %i24,192(%sp)
- finop ; st8 %i25,184(%sp)
- finop ; st8 %i26,176(%sp)
- finop ; st8 %i27,168(%sp)
- finop ; st8 %i28,160(%sp)
- finop ; st8 %i29,152(%sp)
- finop ; st8 %i30,144(%sp)
-#
-# FPU already saved, or saving not necessary
-#
-
-#
-# Switch to the stack passed in as fourth argument to the block
-# routine (%i5) and call the helper routine passed in as the first
-# argument (%i2). Note that the address of the helper's constant
-# block is passed in, so we must derefence it to get the helper's text
-# address.
-#
- finop ; movb8_8 %i2,%c10 # helper's ConstBlock
- finop ; cxnop # Delay slot, fill w/
- finop ; cxnop # .. 2 st8 from above
- finop ; ld8 0(%c10),%c4 # load addr of helper
- finop ; movb8_8 %sp, %i2 # 1st arg to helper
- # is this stack; other
- # args remain in regs
- finop ; movb8_8 %i5,%sp # switch stacks
- finop ; jsr %c14,16(%c4) # call helper
- movi8 3, %i0 ; movi8 0,%c8 # nargs brain dmg
- finop ; cxnop
- finop ; cxnop
-#
-# Here is where behavior differs for threads being restored and threads
-# being started. Blocked threads have a pointer to qt_restore$TXT on
-# the top of their stacks; manufactured stacks have a pointer to qt_start$TXT
-# on the top of their stacks. With this setup, starting threads
-# skip the (unecessary) restore operations.
-#
-# We jump to an offset of 16 to either (1) skip past the two noop pairs
-# at the start of qt_start$TXT, or (2) skip past the two noop pairs
-# after qt_restore$TXT.
-#
- finop ; ld8 8(%sp),%c4
- finop ; cxnop
- finop ; cxnop
- finop ; jmp 16(%c4)
-qt_restore$TXT:
- finop ; cxnop
- finop ; cxnop
-#
-# Point of Restore:
-#
-# The helper funtion will return here. Any result it has placed in
-# a return register (most likely %i0) will not get overwritten below
-# and will consequently be the return value of the blocking routine.
-#
-
-#
-# CEU registers %c15-%c24, %c26-%c30 (%c14 we restore later)
-#
- finop ; ld8 456(%sp),%c15
- finop ; ld8 448(%sp),%c16
- finop ; ld8 440(%sp),%c17
- finop ; ld8 432(%sp),%c18
- finop ; ld8 424(%sp),%c19
- finop ; ld8 416(%sp),%c20
- finop ; ld8 408(%sp),%c21
- finop ; ld8 400(%sp),%c22
- finop ; ld8 392(%sp),%c23
- finop ; ld8 384(%sp),%c24
-#
-# %c25 is the Enclosing Frame Pointer (EFP) -- since C doesn't
-# use nested procedures, we ignore it (leaving a gap, though)
-#
- finop ; ld8 368(%sp),%c26
- finop ; ld8 360(%sp),%c27
- finop ; ld8 352(%sp),%c28
- finop ; ld8 344(%sp),%c29
- finop ; ld8 336(%sp),%c30
-#
-# IPU registers %i12-%i30
-#
- finop ; ld8 328(%sp),%i12
- finop ; ld8 320(%sp),%i13
- finop ; ld8 312(%sp),%i14
- finop ; ld8 304(%sp),%i15
-# (gap to get alignment for ld64)
-# -- Doesn't work on version 1.1.3 of the OS
-# finop ; ld64 256(%sp),%i16
-
- finop ; ld8 256(%sp),%i16
- finop ; ld8 248(%sp),%i17
- finop ; ld8 240(%sp),%i18
- finop ; ld8 232(%sp),%i19
- finop ; ld8 224(%sp),%i20
- finop ; ld8 216(%sp),%i21
- finop ; ld8 208(%sp),%i22
- finop ; ld8 200(%sp),%i23
- finop ; ld8 192(%sp),%i24
- finop ; ld8 184(%sp),%i25
- finop ; ld8 176(%sp),%i26
- finop ; ld8 168(%sp),%i27
- finop ; ld8 160(%sp),%i28
- finop ; ld8 152(%sp),%i29
- finop ; ld8 144(%sp),%i30
-
-#
-# FPU registers don't need to be loaded, or will be loaded by an
-# enclosing scope (e.g., if this is called by qt_block).
-#
-
-#
-# Load the special registers. We don't load the stack ptr because
-# the new stack is passed in as an argument, we don't load the EFP
-# because we don't use it, and we load the return address specially
-# off the top of the stack.
-#
- finop ; ld8 0(%sp),%c14 # return addr
- finop ; ld8 496(%sp),%cp
- finop ; ld8 504(%sp),%fp
-
- finop ; jmp 32(%c14) # jump back to thread
- finop ; movi8 512,%c5 # stack adjust
- finop ; sadd8.ntr 0,%sp,%c5,%sp
-
- .data
- .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
-qt_block:
- .word qt_block$TXT
- .word qt_error
- .word qt_error$TXT
- .word qt_blocki
-#
-# Handle saving and restoring the FPU regs, relying on qt_blocki
-# to save and restore the remaining registers.
-#
- .text
-qt_block$TXT:
- finop ; cxnop # entry prefix
- finop ; cxnop # entry prefix
-
- add8.ntr 29,%i31,%i31 ; movi8 512,%c5 # ICR; stk adjust
- finop ; ssub8.ntr 0,%sp,%c5,%sp
- finop ; st8 %fp,504(%sp) # Save caller's fp
- finop ; st8 %cp,496(%sp) # Save caller's cp
- finop ; st8 %c14,488(%sp) # store ret addr
- finop ; sadd8.ntr 0,%sp,%c5,%fp # Our frame ptr
- finop ; mov8_8 %c10, %cp # Our cp
-
-#
-# Store 8 registers at once...destination must be a multiple of 64
-#
- finop ; st64 %f16,384(%sp)
- finop ; st64 %f24,320(%sp)
- finop ; st64 %f32,256(%sp)
- finop ; st64 %f40,192(%sp)
- finop ; st64 %f48,128(%sp)
- finop ; st64 %f56,64(%sp)
-
-#
-# Call the integer blocking routine, passing the arguments passed to us
-#
- finop ; ld8 24(%cp), %c10
- finop ; cxnop
- finop ; jsr %c14, qt_blocki$TXT
- finop ; cxnop
- finop ; cxnop
- movi8 4,%i0 ; movi8 0,%c8 # nargs brain dmg
-
-#
-# Load 8 registers at once...source must be a multiple of 64
-#
- finop ; ld64 64(%sp),%f56
- finop ; ld64 128(%sp),%f48
- finop ; ld64 192(%sp),%f40
- finop ; ld64 256(%sp),%f32
- finop ; ld64 320(%sp),%f24
- finop ; ld64 384(%sp),%f16
-
- finop ; ld8 488(%sp),%c14
- finop ; ld8 496(%sp),%cp
- finop ; ld8 504(%sp),%fp
- finop ; jmp 32(%c14) # jump back to thread
- finop ; movi8 512,%c5 # stack adjust
- finop ; sadd8.ntr 0,%sp,%c5,%sp
-
-
- .data
- .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
-qt_start:
- .word qt_start$TXT
-#
-# A new thread is set up to "appear" as if it were executing code at
-# the beginning of qt_start and then it called a blocking routine
-# (qt_blocki). So when a new thread starts to run, it gets unblocked
-# by the code above and "returns" to `qt_start$TXT' in the
-# restore step of the switch. Blocked threads jump to 16(qt_restore$TXT),
-# and starting threads jump to 16(qt_start$TXT).
-#
- .text
-qt_start$TXT:
- finop ; cxnop #
- finop ; cxnop #
- finop ; ld8 40(%sp),%c10 # `only' constant block
- finop ; ld8 32(%sp),%i4 # `userf' arg.
- finop ; ld8 24(%sp),%i3 # `t' arg.
- finop ; ld8 0(%c10),%c4 # `only' text location
- finop ; ld8 16(%sp),%i2 # `u' arg.
- finop ; cxnop
- finop ; jsr %c14,16(%c4) # call `only'
-#
-# Pop the frame used to store the thread's initial data
-#
- finop ; sadd8.ntr 0,%sp,128,%sp
- finop ; cxnop
- movi8 2,%i0 ; movi8 0,%c8 # nargs brain dmg
-#
-# If we ever return, it's an error.
-#
- finop ; jmp qt_error$TXT
- finop ; cxnop
- finop ; cxnop
- movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
-
-
-#
-# This stuff is broken
-#
- .data
- .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
-qt_vstart:
- .word qt_vstart$TXT
-
- .text
-qt_vstart$TXT:
- finop ; cxnop # entry prefix
- finop ; cxnop # entry prefix
- finop ; cxnop
- finop ; cxnop
- add8.ntr 11,%i31,%i31 ; movi8 512,%c5
- finop ; ssub8.ntr 0,%sp,%c5,%sp # fix stack
- finop ; ld8 8(%sp),%i2 # load `t' as arg to
- finop ; cxnop # `startup'
- finop ; cxnop
- finop ; ld8 16(%sp),%c10 # `startup' const block
- finop ; cxnop
- finop ; cxnop
- finop ; ld8 0(%c10),%c4 # `startup' text loc.
- finop ; cxnop
- finop ; cxnop
- finop ; jsr %c14,16(%c4) # call `startup'
- finop ; cxnop
- finop ; cxnop
- movi8 1, %i0 ; movi8 0,%c8 # nargs brain dmg
-#
-# finop ; sadd 0,%sp,128,%sp # alter stack
-#
- finop ; ld8 8(%sp),%i2 # load `t' as arg to
- finop ; ld8 8(%sp),%i2 # load `t' as arg to
- finop ; ld8 8(%sp),%i2 # load `t' as arg to
- finop ; ld8 8(%sp),%i2 # load `t' as arg to
-
- finop ; ld8 32(%sp),%c10 # `only' constant block
- finop ; ld8 8(%sp),%i2 # `u' arg.
- finop ; ld8 16(%sp),%i3 # `t' arg.
- finop ; ld8 0(%c10),%c4 # `only' text location
- finop ; ld8 24(%sp),%i4 # `userf' arg.
- finop ; cxnop
- finop ; jsr %c4,16(%c4) # call `only'
- finop ; cxnop
- finop ; cxnop
-#
-# If the callee ever calls `nargs', the following instruction (pair)
-# will be executed. However, we don't know when we compile this code
-# how many args are being passed. So we give our best guess: 0.
-#
- movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
-#
-# If we ever return, it's an error.
-#
- finop ; jmp qt_error$TXT
- finop ; cxnop
- finop ; cxnop
- movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
- .file "ksr1_b.s"
- .def .debug; .endef
-
- .globl b_call_reg$TXT
- .globl b_call_reg
- .globl b_call_imm$TXT
- .globl b_call_imm
- .globl b_add$TXT
- .globl b_add
- .globl b_load$TXT
- .globl b_load
-
-
-b_call_reg:
-b_call_imm:
-b_add:
-b_load:
- .word b_call_reg$TXT
- .word qt_error
- .word qt_error$TXT
-
-
-b_call_reg$TXT:
-b_call_imm$TXT:
-b_add$TXT:
-b_load$TXT:
- finop ; cxnop
- finop ; cxnop
- finop ; ld8 16(%cp),%c4
- finop ; ld8 8(%cp),%cp
- finop ; cxnop
- finop ; cxnop
- finop ; jsr %c4,0(%c4)
- finop ; cxnop
- finop ; cxnop
-
+++ /dev/null
-
-#
-# Hosted compilers for 88k for Meerkat.
-#
-CC = gcc88 -Dm88k -ansi -pedantic -Wall -fno-builtin
-AS = as88
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#include <stdarg.h>
-#include "qt.h"
-
-/* Varargs is harder on the m88k. Parameters are saved on the stack as
- something like (stack grows down to low memory; low at bottom of
- picture):
-
- | :
- | arg8 <-- va_list.__va_stk
- +---
- | :
- +---
- | arg7
- | :
- | iarg0 <-- va_list.__va_reg
- +---
- | :
- | va_list { __va_arg, __va_stk, __va_reg }
- | :
- +---
-
- Here, `va_list.__va_arg' is the number of word-size arguments
- that have already been skipped. Doubles must be double-arligned.
-
- What this means for us is that the user's routine needs to be
- called with an arg list where some of the words in the `__va_stk'
- part of the parameter list have to be promoted to registers.
-
- BUG: doubleword register arguments must be double-aligned. If
- something is passed as an even # arg and used as an odd # arg or
- vice-versa, the code in the called routine (in the new thread) that
- decides how to adjust the index will get it wrong, because it will
- be expect it to be, say, doubleword aligned and it will really be
- singleword aligned.
-
- I'm not sure you can solve this without knowing the types of all
- the arguments. All in all, we never promised varargs would work
- reliably. */
-
-
-
-#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
-
-/* Always allocate at least enough space for 8 args; waste some space
- at the base of the stack to ensure the startup routine doesn't read
- off the end of the stack. */
-
-#define QT_VARGS_MD0(sp, vabytes) \
- ((qt_t *)(((char *)(sp)) - 8*4 - QT_STKROUNDUP(vabytes)))
-
-extern void qt_vstart(void);
-#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_1, qt_vstart))
-
-
- struct qt_t *
-qt_vargs (struct qt_t *qsp, int nbytes, void *vargs,
- void *pt, qt_function_t *startup,
- qt_function_t *vuserf, qt_function_t *cleanup)
-{
- va_list ap;
- int i;
- int n; /* Number of words into original arg list. */
- qt_word_t *sp;
- int *reg; /* Where to read passed-in-reg args. */
- int *stk; /* Where to read passed-on-stk args. */
-
- ap = *(va_list *)vargs;
- qsp = QT_VARGS_MD0 (qsp, nbytes);
- sp = (qt_word_t *)qsp;
-
- reg = (ap.__va_arg < 8)
- ? &ap.__va_reg[ap.__va_arg]
- : 0;
- stk = &ap.__va_stk[8];
- n = ap.__va_arg;
- for (i=0; i<nbytes/sizeof(qt_word_t) && n<8; ++i,++n) {
- sp[i] = *reg++;
- }
- for (; i<nbytes/sizeof(qt_word_t); ++i) {
- sp[i] = *stk++;
- }
-
-#ifdef QT_NDEF
- for (i=0; i<nbytes/sizeof(qt_word_t); ++i) {
- sp[i] = (n < 8)
- ? *reg++
- : *stk++;
- ++n;
- }
-#endif
-
- QT_VARGS_MD1 (QT_VADJ(sp));
- QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
- QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
- QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
- QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
- return ((qt_t *)QT_VADJ(sp));
-}
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#ifndef QT_M88K_H
-#define QT_M88K_H
-
-typedef unsigned long qt_word_t;
-
-#define QT_GROW_DOWN
-
-/* Stack layout on the mips:
-
- Callee-save registers are: $16-$23, $30; $f20-$f30.
- Also save $31, return pc.
-
- Non-varargs:
-
- +---
- | r30 (fp) on startup === 0
- | r25
- | r24
- | r23
- | r22
- | r21
- | r20
- | r19
- | r18
- | r17 on startup === `only'
- | r16 on startup === `userf'
- | r15 on startup === `pt'
- | r14 on startup === `pu'
- | r1 on startup === `qt_start'
- | 0
- | 0
- +---
- | 0
- | ... (8 regs worth === 32 bytes of homing area)
- | 0 <--- sp
- +---
-
- Conventions for varargs:
-
- | :
- | arg8
- +---
- | r30 (fp) arg7
- | r25 arg6
- | r24 arg5
- | r23 arg4
- | r22 arg3
- | r21 arg2
- | r20 arg1
- | r19 arg0
- | r18
- | r17 on startup === `startup'
- | r16 on startup === `vuserf'
- | r15 on startup === `pt'
- | r14 on startup === `cleanup'
- | r1 on startup === `qt_vstart'
- | 0
- | 0
- +---
- | 0
- | ... (8 regs worth === 32 bytes of homing area)
- | 0 <--- sp
- +---
-
- */
-
-
-/* Stack must be doubleword aligned. */
-#define QT_STKALIGN (16) /* Doubleword aligned. */
-
-/* How much space is allocated to hold all the crud for
- initialization: saved registers plus padding to keep the stack
- aligned plus 8 words of padding to use as a `homing area' (for
- r2-r9) when calling helper functions on the stack of the (not yet
- started) thread. The varargs save area is small because it gets
- overlapped with the top of the parameter list. In case the
- parameter list is less than 8 args, QT_ARGS_MD0 adds some dead
- space at the top of the stack. */
-
-#define QT_STKBASE (16*4 + 8*4)
-#define QT_VSTKBASE (8*4 + 8*4)
-
-
-/* Index of various registers. */
-#define QT_1 (8+2)
-#define QT_14 (8+3)
-#define QT_15 (8+4)
-#define QT_16 (8+5)
-#define QT_17 (8+6)
-#define QT_30 (8+15)
-
-
-/* When a never-before-run thread is restored, the return pc points
- to a fragment of code that starts the thread running. For
- non-vargs functions, it sets up arguments and calls the client's
- `only' function. For varargs functions, the startup code calls the
- startup, user, and cleanup functions.
-
- For non-varargs functions, we set the frame pointer to 0 to
- null-terminate the call chain.
-
- For varargs functions, the frame pointer register is used to hold
- one of the arguments, so that all arguments can be laid out in
- memory by the conventional `qt_vargs' varargs initialization
- routine.
-
- The varargs startup routine always reads 8 words of arguments from
- the stack. If there are less than 8 words of arguments, then the
- arg list could call off the top of the stack. To prevent fall-off,
- always allocate 8 words. */
-
-extern void qt_start(void);
-#define QT_ARGS_MD(sp) \
- (QT_SPUT (sp, QT_1, qt_start), \
- QT_SPUT (sp, QT_30, 0))
-
-
-/* The m88k uses a struct for `va_list', so pass a pointer to the
- struct. */
-
-typedef void (qt_function_t)(void);
-
-struct qt_t;
-extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes,
- void *vargs, void *pt,
- qt_function_t *startup,
- qt_function_t *vuserf,
- qt_function_t *cleanup);
-
-#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
- (qt_vargs (sp, nbytes, &(vargs), pt, (qt_function_t *)startup, \
- (qt_function_t *)vuserf, (qt_function_t *)cleanup))
-
-
-/* The *index* (positive offset) of where to put each value. */
-#define QT_ONLY_INDEX (QT_17)
-#define QT_USER_INDEX (QT_16)
-#define QT_ARGT_INDEX (QT_15)
-#define QT_ARGU_INDEX (QT_14)
-
-#define QT_VCLEANUP_INDEX (QT_14)
-#define QT_VUSERF_INDEX (QT_16)
-#define QT_VSTARTUP_INDEX (QT_17)
-#define QT_VARGT_INDEX (QT_15)
-
-#endif /* ndef QT_M88K_H */
+++ /dev/null
-/* m88k.s -- assembly support. */
-
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-/* Callee-save r14..r25, r31(sp), r30(fp). r1 === return pc.
- * Argument registers r2..r9, return value r2..r3.
- *
- * On startup, restore regs so retpc === call to a function to start.
- *
- * We're going to call a function (r2) from within the context switch
- * routine. Call it on the new thread's stack on behalf of the old
- * thread.
- */
-
- .globl _qt_block
- .globl _qt_blocki
- .globl _qt_abort
- .globl _qt_start
- .globl _qt_vstart
-
- /*
- ** r2: ptr to function to call once curr is suspended
- ** and control is on r5's stack.
- ** r3: 1'th arg to *r2.
- ** r4: 2'th arg to *r2.
- ** r5: sp of thread to suspend.
- **
- ** The helper routine returns a value that is passed on as the
- ** return value from the blocking routine. Since we don't
- ** touch r2 between the helper's return and the end of
- ** function, we get this behavior for free.
- **
- ** Same entry for integer-only and floating-point, since there
- ** are no separate integer and floating-point registers.
- **
- ** Each procedure call sets aside a ``home region'' of 8 regs
- ** for r2-r9 for varargs. For context switches we don't use
- ** the ``home region'' for varargs so use it to save regs.
- ** Allocate 64 bytes of save space -- use 32 bytes of register
- ** save area passed in to us plus 32 bytes we allcated, use
- ** the other 32 bytes for save area for a save area to call
- ** the helper function.
- */
-_qt_block:
-_qt_blocki:
- sub r31, r31,64 /* Allocate reg save space. */
- st r1, r31,8+32 /* Save callee-save registers. */
- st r14, r31,12+32
- st.d r15, r31,16+32
- st.d r17, r31,24+32
- st.d r19, r31,32+32
- st.d r21, r31,40+32
- st.d r23, r31,48+32
- st r25, r31,56+32
- st r30, r31,60+32
-
-_qt_abort:
- addu r14, r31,0 /* Remember old sp. */
- addu r31, r5,0 /* Set new sp. */
- jsr.n r2 /* Call helper. */
- addu r2, r14,0 /* Pass old sp as an arg0 to helper. */
-
- ld r1, r31,8+32 /* Restore callee-save registers. */
- ld r14, r31,12+32
- ld.d r15, r31,16+32
- ld.d r17, r31,24+32
- ld.d r19, r31,32+32
- ld.d r21, r31,40+32
- ld.d r23, r31,48+32
- ld r25, r31,56+32
- ld r30, r31,60+32
-
- jmp.n r1 /* Return to new thread's caller. */
- addu r31, r31,64 /* Free register save space. */
-
-
- /*
- ** Non-varargs thread startup.
- ** See `m88k.h' for register use conventions.
- */
-_qt_start:
- addu r2, r14,0 /* Set user arg `pu'. */
- addu r3, r15,0 /* ... user function pt. */
- jsr.n r17 /* Call `only'. */
- addu r4, r16,0 /* ... user function userf. */
-
- bsr _qt_error /* `only' erroniously returned. */
-
-
- /*
- ** Varargs thread startup.
- ** See `m88k.h' for register use conventions.
- **
- ** Call the `startup' function with just argument `pt'.
- ** Then call `vuserf' with 8 register args plus any
- ** stack args.
- ** Then call `cleanup' with `pt' and the return value
- ** from `vuserf'.
- */
-_qt_vstart:
- addu r18, r30,0 /* Remember arg7 to `vuserf'. */
- addu r30, r0,0 /* Null-terminate call chain. */
-
- jsr.n r17 /* Call `startup'. */
- addu r2, r15,0 /* `pt' is arg0 to `startup'. */
-
- addu r2, r19,0 /* Set arg0. */
- addu r3, r20,0 /* Set arg1. */
- addu r4, r21,0 /* Set arg2. */
- addu r5, r22,0 /* Set arg3. */
- addu r6, r23,0 /* Set arg4. */
- addu r7, r24,0 /* Set arg5. */
- addu r8, r25,0 /* Set arg6. */
- jsr.n r16 /* Call `vuserf'. */
- addu r9, r18,0 /* Set arg7. */
-
- addu r3, r2,0 /* Ret. value is arg1 to `cleanup'. */
- jsr.n r14 /* Call `cleanup'. */
- addu r2, r15,0 /* `pt' is arg0 to `cleanup'. */
-
- bsr _qt_error /* `cleanup' erroniously returned. */
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
- .text
- .globl _b_call_reg
- .globl _b_call_imm
- .globl _b_add
- .globl _b_load
-
-_b_null:
- jmp r1
-
-_b_call_reg:
- subu r31, r31,8 /* Alloc ret pc save space. */
- st r1, r31,32 /* Save ret pc. */
- or.u r3, r0,hi16(_b_null) /* Put call addr in a reg. */
- or r3, r3,lo16(_b_null)
- jsr r3
-L0:
- jsr r3
- jsr r3
- jsr r3
- jsr.n r3
- subu r2, r2,5 /* Decrement #of iter to go. */
- bcnd.n gt0,r2,L0
- jsr r3
-
- ld r1, r31,32
- jmp r1
-
-
-_b_call_imm:
- subu r31, r31,8 /* Alloc ret pc save space. */
- st r1, r31,32 /* Save ret pc. */
- bsr _b_null
-L1:
- bsr _b_null
- bsr _b_null
- bsr _b_null
- bsr.n _b_null
- subu r2, r2,5 /* Decrement #of iter to go. */
- bcnd.n gt0,r2,L1
- bsr _b_null
-
- ld r1, r31,32
- jmp r1
-
-_b_add:
- add r0, r3,r4
-L2:
- add r3, r4,r5
- add r4, r5,r6
- add r5, r6,r7
- add r8, r9,r0
- add r0, r3,r4
- add r3, r4,r5
- add r4, r5,r6
- add r5, r6,r7
- add r8, r9,r0
-
- add r0, r3,r4
- add r3, r4,r5
- add r4, r5,r6
- add r5, r6,r7
- add r8, r9,r0
- add r0, r3,r4
- add r3, r4,r5
- add r4, r5,r6
- add r5, r6,r7
- add r8, r9,r0
-
- subu r2, r2,20 /* Decrement #of iter to go. */
- bcnd.n gt0,r2,L2
- add r0, r3,r4
-
- jmp r1
-
-
-_b_load:
- ld r0, r31,0
-L3:
- ld r3, r31,4
- ld r4, r31,8
- ld r5, r31,12
- ld r6, r31,16
- ld r0, r31,0
- ld r3, r31,4
- ld r4, r31,8
- ld r5, r31,12
- ld r6, r31,16
-
- ld r0, r31,0
- ld r3, r31,4
- ld r4, r31,8
- ld r5, r31,12
- ld r6, r31,16
- ld r0, r31,0
- ld r3, r31,4
- ld r4, r31,8
- ld r5, r31,12
- ld r6, r31,16
-
- subu r2, r2,20 /* Decrement #of iter to go. */
- bcnd.n gt0,r2,L3
- ld r0, r31,0
-
- jmp r1
+++ /dev/null
-/* mips.s -- assembly support. */
-
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-/* Callee-save $16-$23, $30-$31.
- *
- * $25 is used as a procedure value pointer, used to discover constants
- * in a callee. Thus, each caller here sets $25 before the call.
- *
- * On startup, restore regs so retpc === call to a function to start.
- * We're going to call a function ($4) from within this routine.
- * We're passing 3 args, therefore need to allocate 12 extra bytes on
- * the stack for a save area. The start routine needs a like 16-byte
- * save area. Must be doubleword aligned (_mips r3000 risc
- * architecture_, gerry kane, pg d-23).
- */
-
-/*
- * Modified by Assar Westerlund <assar@sics.se> to support Irix 5.x
- * calling conventions for dynamically-linked code.
- */
-
- /* Make this position-independent code. */
- .option pic2
-
- .globl qt_block
- .globl qt_blocki
- .globl qt_abort
- .globl qt_start
- .globl qt_vstart
-
- /*
- ** $4: ptr to function to call once curr is suspended
- ** and control is on $7's stack.
- ** $5: 1'th arg to $4.
- ** $6: 2'th arg to $4
- ** $7: sp of thread to suspend.
- **
- ** Totally gross hack: The MIPS calling convention reserves
- ** 4 words on the stack for a0..a3. This routine "ought" to
- ** allocate space for callee-save registers plus 4 words for
- ** the helper function, but instead we use the 4 words
- ** provided by the function that called us (we don't need to
- ** save our argument registers). So what *appears* to be
- ** allocating only 40 bytes is actually allocating 56, by
- ** using the caller's 16 bytes.
- **
- ** The helper routine returns a value that is passed on as the
- ** return value from the blocking routine. Since we don't
- ** touch $2 between the helper's return and the end of
- ** function, we get this behavior for free.
- */
-qt_blocki:
- sub $sp,$sp,40 /* Allocate reg save space. */
- sw $16, 0+16($sp)
- sw $17, 4+16($sp)
- sw $18, 8+16($sp)
- sw $19,12+16($sp)
- sw $20,16+16($sp)
- sw $21,20+16($sp)
- sw $22,24+16($sp)
- sw $23,28+16($sp)
- sw $30,32+16($sp)
- sw $31,36+16($sp)
- add $2, $sp,$0 /* $2 <= old sp to pass to func@$4. */
-qt_abort:
- add $sp, $7,$0 /* $sp <= new sp. */
- .set noreorder
- add $25, $4,$0 /* Set helper function procedure value. */
- jal $31,$25 /* Call helper func@$4 . */
- add $4, $2,$0 /* $a0 <= pass old sp as a parameter. */
- .set reorder
- lw $31,36+16($sp) /* Restore callee-save regs... */
- lw $30,32+16($sp)
- lw $23,28+16($sp)
- lw $22,24+16($sp)
- lw $21,20+16($sp)
- lw $20,16+16($sp)
- lw $19,12+16($sp)
- lw $18, 8+16($sp)
- lw $17, 4+16($sp)
- lw $16, 0+16($sp) /* Restore callee-save */
-
- add $sp,$sp,40 /* Deallocate reg save space. */
- j $31 /* Return to caller. */
-
- /*
- ** Non-varargs thread startup.
- ** Note: originally, 56 bytes were allocated on the stack.
- ** The thread restore routine (_blocki/_abort) removed 40
- ** of them, which means there is still 16 bytes for the
- ** argument area required by the MIPS calling convention.
- */
-qt_start:
- add $4, $16,$0 /* Load up user function pu. */
- add $5, $17,$0 /* ... user function pt. */
- add $6, $18,$0 /* ... user function userf. */
- add $25, $19,$0 /* Set `only' procedure value. */
- jal $31,$25 /* Call `only'. */
- la $25,qt_error /* Set `qt_error' procedure value. */
- j $25
-
-
- /*
- ** Save calle-save floating-point regs $f20-$f30
- ** See comment in `qt_block' about calling conventinos and
- ** reserved space. Use the same trick here, but here we
- ** actually have to allocate all the bytes since we have to
- ** leave 4 words leftover for `qt_blocki'.
- **
- ** Return value from `qt_block' is the same as the return from
- ** `qt_blocki'. We get that for free since we don't touch $2
- ** between the return from `qt_blocki' and the return from
- ** `qt_block'.
- */
-qt_block:
- sub $sp, $sp,56 /* 6 8-byte regs, saved ret pc, aligned. */
- swc1 $f20, 0+16($sp)
- swc1 $f22, 8+16($sp)
- swc1 $f24, 16+16($sp)
- swc1 $f26, 24+16($sp)
- swc1 $f28, 32+16($sp)
- swc1 $f30, 40+16($sp)
- sw $31, 48+16($sp)
- jal qt_blocki
- lwc1 $f20, 0+16($sp)
- lwc1 $f22, 8+16($sp)
- lwc1 $f24, 16+16($sp)
- lwc1 $f26, 24+16($sp)
- lwc1 $f28, 32+16($sp)
- lwc1 $f30, 40+16($sp)
- lw $31, 48+16($sp)
- add $sp, $sp,56
- j $31
-
-
- /*
- ** First, call `startup' with the `pt' argument.
- **
- ** Next, call the user's function with all arguments.
- ** Note that we don't know whether args were passed in
- ** integer regs, fp regs, or on the stack (See Gerry Kane
- ** "MIPS R2000 RISC Architecture" pg D-22), so we reload
- ** all the registers, possibly with garbage arguments.
- **
- ** Finally, call `cleanup' with the `pt' argument and with
- ** the return value from the user's function. It is an error
- ** for `cleanup' to return.
- */
-qt_vstart:
- add $4, $17,$0 /* `pt' is arg0 to `startup'. */
- add $25, $18,$0 /* Set `startup' procedure value. */
- jal $31, $25 /* Call `startup'. */
-
- add $sp, $sp,16 /* Free extra save space. */
- lw $4, 0($sp) /* Load up args. */
- lw $5, 4($sp)
- lw $6, 8($sp)
- lw $7, 12($sp)
- lwc1 $f12, 0($sp) /* Load up fp args. */
- lwc1 $f14, 8($sp)
- add $25, $19,$0 /* Set `userf' procedure value. */
- jal $31,$25 /* Call `userf'. */
-
- add $4, $17,$0 /* `pt' is arg0 to `cleanup'. */
- add $5, $2,$0 /* Ret. val is arg1 to `cleanup'. */
- add $25, $16,$0 /* Set `cleanup' procedure value. */
- jal $31, $25 /* Call `cleanup'. */
-
- la $25,qt_error /* Set `qt_error' procedure value. */
- j $25
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#ifndef QT_MIPS_H
-#define QT_MIPS_H
-
-typedef unsigned long qt_word_t;
-
-#define QT_GROW_DOWN
-
-/* Stack layout on the mips:
-
- Callee-save registers are: $16-$23, $30; $f20-$f30.
- Also save $31, return pc.
-
- Non-varargs:
-
- +---
- | $f30 The first clump is only saved if `qt_block'
- | $f28 is called, in which case it saves the fp regs
- | $f26 then calls `qt_blocki' to save the int regs.
- | $f24
- | $f22
- | $f20
- | $31 === return pc in `qt_block'
- +---
- | $31 === return pc; on startup == qt_start
- | $30
- | $23
- | $22
- | $21
- | $20
- | $19 on startup === only
- | $18 on startup === $a2 === userf
- | $17 on startup === $a1 === pt
- | $16 on startup === $a0 === pu
- | <a3> save area req'd by MIPS calling convention
- | <a2> save area req'd by MIPS calling convention
- | <a1> save area req'd by MIPS calling convention
- | <a0> save area req'd by MIPS calling convention <--- sp
- +---
-
- Conventions for varargs:
-
- | args ...
- +---
- | :
- | :
- | $21
- | $20
- | $19 on startup === `userf'
- | $18 on startup === `startup'
- | $17 on startup === `pt'
- | $16 on startup === `cleanup'
- | <a3>
- | <a2>
- | <a1>
- | <a0> <--- sp
- +---
-
- Note: if we wanted to, we could muck about and try to get the 4
- argument registers loaded in to, e.g., $22, $23, $30, and $31,
- and the return pc in, say, $20. Then, the first 4 args would
- not need to be loaded from memory, they could just use
- register-to-register copies. */
-
-
-/* Stack must be doubleword aligned. */
-#define QT_STKALIGN (8) /* Doubleword aligned. */
-
-/* How much space is allocated to hold all the crud for
- initialization: $16-$23, $30, $31. Just do an integer restore,
- no need to restore floating-point. Four words are needed for the
- argument save area for the helper function that will be called for
- the old thread, just before the new thread starts to run. */
-
-#define QT_STKBASE (14 * 4)
-#define QT_VSTKBASE QT_STKBASE
-
-
-/* Offsets of various registers. */
-#define QT_31 (9+4)
-#define QT_19 (3+4)
-#define QT_18 (2+4)
-#define QT_17 (1+4)
-#define QT_16 (0+4)
-
-
-/* When a never-before-run thread is restored, the return pc points
- to a fragment of code that starts the thread running. For
- non-vargs functions, it just calls the client's `only' function.
- For varargs functions, it calls the startup, user, and cleanup
- functions.
-
- The varargs startup routine always reads 4 words of arguments from
- the stack. If there are less than 4 words of arguments, then the
- startup routine can read off the top of the stack. To prevent
- errors we always allocate 4 words. If there are more than 3 words
- of arguments, the 4 preallocated words are simply wasted. */
-
-extern void qt_start(void);
-#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_31, qt_start))
-
-#define QT_VARGS_MD0(sp, vabytes) \
- ((qt_t *)(((char *)(sp)) - 4*4 - QT_STKROUNDUP(vabytes)))
-
-extern void qt_vstart(void);
-#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_31, qt_vstart))
-
-#define QT_VARGS_DEFAULT
-
-
-/* The *index* (positive offset) of where to put each value. */
-#define QT_ONLY_INDEX (QT_19)
-#define QT_USER_INDEX (QT_18)
-#define QT_ARGT_INDEX (QT_17)
-#define QT_ARGU_INDEX (QT_16)
-
-#define QT_VCLEANUP_INDEX (QT_16)
-#define QT_VUSERF_INDEX (QT_19)
-#define QT_VSTARTUP_INDEX (QT_18)
-#define QT_VARGT_INDEX (QT_17)
-
-#endif /* ndef QT_MIPS_H */
+++ /dev/null
-/* mips.s -- assembly support. */
-
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-/* Callee-save $16-$23, $30-$31.
- *
- * On startup, restore regs so retpc === call to a function to start.
- * We're going to call a function ($4) from within this routine.
- * We're passing 3 args, therefore need to allocate 12 extra bytes on
- * the stack for a save area. The start routine needs a like 16-byte
- * save area. Must be doubleword aligned (_mips r3000 risc
- * architecture_, gerry kane, pg d-23).
- */
-
- .globl qt_block
- .globl qt_blocki
- .globl qt_abort
- .globl qt_start
- .globl qt_vstart
-
- /*
- ** $4: ptr to function to call once curr is suspended
- ** and control is on $7's stack.
- ** $5: 1'th arg to $4.
- ** $6: 2'th arg to $4
- ** $7: sp of thread to suspend.
- **
- ** Totally gross hack: The MIPS calling convention reserves
- ** 4 words on the stack for a0..a3. This routine "ought" to
- ** allocate space for callee-save registers plus 4 words for
- ** the helper function, but instead we use the 4 words
- ** provided by the function that called us (we don't need to
- ** save our argument registers). So what *appears* to be
- ** allocating only 40 bytes is actually allocating 56, by
- ** using the caller's 16 bytes.
- **
- ** The helper routine returns a value that is passed on as the
- ** return value from the blocking routine. Since we don't
- ** touch $2 between the helper's return and the end of
- ** function, we get this behavior for free.
- */
-qt_blocki:
- sub $sp,$sp,40 /* Allocate reg save space. */
- sw $16, 0+16($sp)
- sw $17, 4+16($sp)
- sw $18, 8+16($sp)
- sw $19,12+16($sp)
- sw $20,16+16($sp)
- sw $21,20+16($sp)
- sw $22,24+16($sp)
- sw $23,28+16($sp)
- sw $30,32+16($sp)
- sw $31,36+16($sp)
- add $2, $sp,$0 /* $2 <= old sp to pass to func@$4. */
-qt_abort:
- add $sp, $7,$0 /* $sp <= new sp. */
- .set noreorder
- jal $31,$4 /* Call helper func@$4 . */
- add $4, $2,$0 /* $a0 <= pass old sp as a parameter. */
- .set reorder
- lw $31,36+16($sp) /* Restore callee-save regs... */
- lw $30,32+16($sp)
- lw $23,28+16($sp)
- lw $22,24+16($sp)
- lw $21,20+16($sp)
- lw $20,16+16($sp)
- lw $19,12+16($sp)
- lw $18, 8+16($sp)
- lw $17, 4+16($sp)
- lw $16, 0+16($sp) /* Restore callee-save */
-
- add $sp,$sp,40 /* Deallocate reg save space. */
- j $31 /* Return to caller. */
-
- /*
- ** Non-varargs thread startup.
- ** Note: originally, 56 bytes were allocated on the stack.
- ** The thread restore routine (_blocki/_abort) removed 40
- ** of them, which means there is still 16 bytes for the
- ** argument area required by the MIPS calling convention.
- */
-qt_start:
- add $4, $16,$0 /* Load up user function pu. */
- add $5, $17,$0 /* ... user function pt. */
- add $6, $18,$0 /* ... user function userf. */
- jal $31,$19 /* Call `only'. */
- j qt_error
-
-
- /*
- ** Save calle-save floating-point regs $f20-$f30
- ** See comment in `qt_block' about calling conventinos and
- ** reserved space. Use the same trick here, but here we
- ** actually have to allocate all the bytes since we have to
- ** leave 4 words leftover for `qt_blocki'.
- **
- ** Return value from `qt_block' is the same as the return from
- ** `qt_blocki'. We get that for free since we don't touch $2
- ** between the return from `qt_blocki' and the return from
- ** `qt_block'.
- */
-qt_block:
- sub $sp, $sp,56 /* 6 8-byte regs, saved ret pc, aligned. */
- swc1 $f20, 0+16($sp)
- swc1 $f22, 8+16($sp)
- swc1 $f24, 16+16($sp)
- swc1 $f26, 24+16($sp)
- swc1 $f28, 32+16($sp)
- swc1 $f30, 40+16($sp)
- sw $31, 48+16($sp)
- jal qt_blocki
- lwc1 $f20, 0+16($sp)
- lwc1 $f22, 8+16($sp)
- lwc1 $f24, 16+16($sp)
- lwc1 $f26, 24+16($sp)
- lwc1 $f28, 32+16($sp)
- lwc1 $f30, 40+16($sp)
- lw $31, 48+16($sp)
- add $sp, $sp,56
- j $31
-
-
- /*
- ** First, call `startup' with the `pt' argument.
- **
- ** Next, call the user's function with all arguments.
- ** Note that we don't know whether args were passed in
- ** integer regs, fp regs, or on the stack (See Gerry Kane
- ** "MIPS R2000 RISC Architecture" pg D-22), so we reload
- ** all the registers, possibly with garbage arguments.
- **
- ** Finally, call `cleanup' with the `pt' argument and with
- ** the return value from the user's function. It is an error
- ** for `cleanup' to return.
- */
-qt_vstart:
- add $4, $17,$0 /* `pt' is arg0 to `startup'. */
- jal $31, $18 /* Call `startup'. */
-
- add $sp, $sp,16 /* Free extra save space. */
- lw $4, 0($sp) /* Load up args. */
- lw $5, 4($sp)
- lw $6, 8($sp)
- lw $7, 12($sp)
- lwc1 $f12, 0($sp) /* Load up fp args. */
- lwc1 $f14, 8($sp)
- jal $31,$19 /* Call `userf'. */
-
- add $4, $17,$0 /* `pt' is arg0 to `cleanup'. */
- add $5, $2,$0 /* Ret. val is arg1 to `cleanup'. */
- jal $31, $16 /* Call `cleanup'. */
-
- j qt_error
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
- .globl b_call_reg
- .globl b_call_imm
- .globl b_add
- .globl b_load
-
- .ent b_null
-b_null:
- j $31
- .end b_null
-
- .ent b_call_reg
-b_call_reg:
- la $5,b_null
- add $6, $31,0
-$L0:
- jal $5
- jal $5
- jal $5
- jal $5
- jal $5
-
- sub $4, $4,5
- bgtz $4,$L0
- j $6
- .end
-
-
- .ent b_call_imm
-b_call_imm:
- add $6, $31,0
-$L1:
- jal b_null
- jal b_null
- jal b_null
- jal b_null
- jal b_null
-
- sub $4, $4,5
- bgtz $4,$L1
- j $6
- .end
-
-
- .ent b_add
-b_add:
- add $5, $0,$4
- add $6, $0,$4
- add $7, $0,$4
- add $8, $0,$4
-$L2:
- sub $4, $4,5
- sub $5, $5,5
- sub $6, $6,5
- sub $7, $7,5
- sub $8, $8,5
-
- sub $4, $4,5
- sub $5, $5,5
- sub $6, $6,5
- sub $7, $7,5
- sub $8, $8,5
-
- bgtz $4,$L2
- j $31
- .end
-
-
- .ent b_load
-b_load:
-$L3:
- ld $0, 0($sp)
- ld $0, 4($sp)
- ld $0, 8($sp)
- ld $0, 12($sp)
- ld $0, 16($sp)
-
- ld $0, 20($sp)
- ld $0, 24($sp)
- ld $0, 28($sp)
- ld $0, 32($sp)
- ld $0, 36($sp)
-
- sub $4, $4,10
- bgtz $4,$L3
- j $31
- .end
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-char const qtmd_rcsid[] = "$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/md/null.c,v 1.1 1996-10-01 03:34:16 mdj Exp $";
+++ /dev/null
-Solaris 2.x is like System V (maybe it *is* System V?) and is different
-from older versions in that it uses no leading underscore for variable
-and function names. That is, the old convention was:
-
- foo(){}
-
-got compiled as
-
- .globl _foo
- _foo:
-
-and is now compiled as
-
- .globl foo
- foo:
-
-The `config' script should fix up the older (leading underscore) versions
-of the machine-dependent files to use the newer (no leading underscore)
-calling conventions.
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#ifndef QT_SPARC_H
-#define QT_SPARC_H
-
-typedef unsigned long qt_word_t;
-
-/* Stack layout on the sparc:
-
- non-varargs:
-
- +---
- | <blank space for alignment>
- | %o7 == return address -> qt_start
- | %i7
- | %i6 == frame pointer -> 0 (NULL-terminated stack frame chain)
- | %i5 -> only
- | %i4 -> userf
- | %i3
- | %i2 -> pt
- | %i1 -> pu
- | %i0
- | %l7
- | %l6
- | %l5
- | %l4
- | %l3
- | %l2
- | %l1
- | %l0 <--- qt_t.sp
- +---
-
- varargs:
-
- | :
- | :
- | argument list
- | one-word aggregate return pointer
- +---
- | <blank space for alignment>
- | %o7 == return address -> qt_vstart
- | %i7
- | %i6 == frame pointer -> 0 (NULL-terminated stack frame chain)
- | %i5 -> startup
- | %i4 -> userf
- | %i3 -> cleanup
- | %i2 -> pt
- | %i1
- | %i0
- | %l7
- | %l6
- | %l5
- | %l4
- | %l3
- | %l2
- | %l1
- | %l0 <--- qt_t.sp
- +---
-
- */
-
-
-/* What to do to start a thread running. */
-extern void qt_start (void);
-extern void qt_vstart (void);
-
-
-/* Hold 17 saved registers + 1 word for alignment. */
-#define QT_STKBASE (18 * 4)
-#define QT_VSTKBASE QT_STKBASE
-
-
-/* Stack must be doubleword aligned. */
-#define QT_STKALIGN (8) /* Doubleword aligned. */
-
-#define QT_ONLY_INDEX (QT_I5)
-#define QT_USER_INDEX (QT_I4)
-#define QT_ARGT_INDEX (QT_I2)
-#define QT_ARGU_INDEX (QT_I1)
-
-#define QT_VSTARTUP_INDEX (QT_I5)
-#define QT_VUSERF_INDEX (QT_I4)
-#define QT_VCLEANUP_INDEX (QT_I3)
-#define QT_VARGT_INDEX (QT_I2)
-
-#define QT_O7 (16)
-#define QT_I6 (14)
-#define QT_I5 (13)
-#define QT_I4 (12)
-#define QT_I3 (11)
-#define QT_I2 (10)
-#define QT_I1 ( 9)
-
-
-/* The thread will ``return'' to the `qt_start' routine to get things
- going. The normal return sequence takes us to QT_O7+8, so we
- pre-subtract 8. The frame pointer chain is 0-terminated to prevent
- the trap handler from chasing off in to random memory when flushing
- stack windows. */
-
-#define QT_ARGS_MD(top) \
- (QT_SPUT ((top), QT_O7, ((void *)(((int)qt_start)-8))), \
- QT_SPUT ((top), QT_I6, 0))
-
-
-/* The varargs startup routine always reads 6 words of arguments
- (6 argument registers) from the stack, offset by one word to
- allow for an aggregate return area pointer. If the varargs
- routine actually pushed fewer words than that, qt_vstart could read
- off the top of the stack. To prevent errors, we always allocate 8
- words. The space is often just wasted. */
-
-#define QT_VARGS_MD0(sp, vabytes) \
- ((qt_t *)(((char *)(sp)) - 8*4 - QT_STKROUNDUP(vabytes)))
-
-#define QT_VARGS_MD1(sp) \
- (QT_SPUT (sp, QT_O7, ((void *)(((int)qt_vstart)-8))))
-
-/* The SPARC has wierdo calling conventions which stores a hidden
- parameter for returning aggregate values, so the rest of the
- parameters are shoved up the stack by one place. */
-#define QT_VARGS_ADJUST(sp) (((char *)sp)+4)
-
-#define QT_VARGS_DEFAULT
-
-
-#define QT_GROW_DOWN
-
-#endif /* ndef QT_SPARC_H */
+++ /dev/null
-/* sparc.s -- assembly support for the `qt' thread building kit. */
-
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-/* #include <machine/trap.h> */
-
- .text
- .align 4
- .global qt_blocki
- .global qt_block
- .global qt_abort
- .global qt_start
- .global qt_vstart
-
-/* Register assignment:
-// %o0: incoming `helper' function to call after cswap
-// also used as outgoing sp of old thread (qt_t *)
-// %o1, %o2:
-// parameters to `helper' function called after cswap
-// %o3: sp of new thread
-// %o5: tmp used to save old thread sp, while using %o0
-// to call `helper' f() after cswap.
-//
-//
-// Aborting a thread is easy if there are no cached register window
-// frames: just switch to the new stack and away we go. If there are
-// cached register window frames they must all be written back to the
-// old stack before we move to the new stack. If we fail to do the
-// writeback then the old stack memory can be written with register
-// window contents e.g., after the stack memory has been freed and
-// reused.
-//
-// If you don't believe this, try setting the frame pointer to zero
-// once we're on the new stack. This will not affect correctnes
-// otherwise because the frame pointer will eventually get reloaded w/
-// the new thread's frame pointer. But it will be zero briefly before
-// the reload. You will eventually (100,000 cswaps later on a small
-// SPARC machine that I tried) get an illegal instruction trap from
-// the kernel trying to flush a cached window to location 0x0.
-//
-// Solution: flush windows before switching stacks, which invalidates
-// all the other register windows. We could do the trap
-// conditionally: if we're in the lowest frame of a thread, the fp is
-// zero already so we know there's nothing cached. But we expect most
-// aborts will be done from a first function that does a `save', so we
-// will rarely save anything and always pay the cost of testing to see
-// if we should flush.
-//
-// All floating-point registers are caller-save, so this routine
-// doesn't need to do anything to save and restore them.
-//
-// `qt_block' and `qt_blocki' return the same value as the value
-// returned by the helper function. We get this ``for free''
-// since we don't touch the return value register between the
-// return from the helper function and return from qt_block{,i}.
-*/
-
-qt_block:
-qt_blocki:
- sub %sp, 8, %sp /* Allocate save area for return pc. */
- st %o7, [%sp+64] /* Save return pc. */
-qt_abort:
- ta 0x03 /* Save locals and ins. */
- mov %sp, %o5 /* Remember old sp w/o chng ins/locals. */
- sub %o3, 64, %sp /* Allocate kwsa, switch stacks. */
- call %o0, 0 /* Call `helper' routine. */
- mov %o5, %o0 /* Pass old thread to qt_after_t() */
- /* .. along w/ args in %o1 & %o2. */
-
- /* Restore callee-save regs. The kwsa
- // is on this stack, so offset all
- // loads by sizeof(kwsa), 64 bytes.
- */
- ldd [%sp+ 0+64], %l0
- ldd [%sp+ 8+64], %l2
- ldd [%sp+16+64], %l4
- ldd [%sp+24+64], %l6
- ldd [%sp+32+64], %i0
- ldd [%sp+40+64], %i2
- ldd [%sp+48+64], %i4
- ldd [%sp+56+64], %i6
- ld [%sp+64+64], %o7 /* Restore return pc. */
-
- retl /* Return to address in %o7. */
- add %sp, 72, %sp /* Deallocate kwsa, ret pc area. */
-
-
-/* The function calling conventions say there has to be a 1-word area
-// in the caller's stack to hold a pointer to space for aggregate
-// return values. It also says there should be a 6-word area to hold
-// %o0..%o5 if the callee wants to save them (why? I don't know...)
-// Round up to 8 words to maintain alignment.
-//
-// Parameter values were stored in callee-save regs and are moved to
-// the parameter registers.
-*/
-qt_start:
- mov %i1, %o0 /* `pu': Set up args to `only'. */
- mov %i2, %o1 /* `pt'. */
- mov %i4, %o2 /* `userf'. */
- call %i5, 0 /* Call client function. */
- sub %sp, 32, %sp /* Allocate 6-word callee space. */
-
- call qt_error, 0 /* `only' erroniously returned. */
- nop
-
-
-/* Same comments as `qt_start' about allocating rounded-up 7-word
-// save areas. */
-
-qt_vstart:
- sub %sp, 32, %sp /* Allocate 7-word callee space. */
- call %i5, 0 /* call `startup'. */
- mov %i2, %o0 /* .. with argument `pt'. */
-
- add %sp, 32, %sp /* Use 7-word space in varargs. */
- ld [%sp+ 4+64], %o0 /* Load arg0 ... */
- ld [%sp+ 8+64], %o1
- ld [%sp+12+64], %o2
- ld [%sp+16+64], %o3
- ld [%sp+20+64], %o4
- call %i4, 0 /* Call `userf'. */
- ld [%sp+24+64], %o5
-
- /* Use 6-word space in varargs. */
- mov %o0, %o1 /* Pass return value from userf */
- call %i3, 0 /* .. when call `cleanup. */
- mov %i2, %o0 /* .. along with argument `pt'. */
-
- call qt_error, 0 /* `cleanup' erroniously returned. */
- nop
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
- .globl b_call_reg
- .globl b_call_imm
- .globl b_add
- .globl b_load
-
-b_null:
- retl
- nop
-
-b_call_reg:
- sethi %hi(b_null),%o4
- or %o4,%lo(b_null),%o4
- add %o7,%g0, %o3
-L0:
- call %o4
- nop
- call %o4
- nop
- call %o4
- nop
- call %o4
- nop
- call %o4
- nop
-
- subcc %o0,1,%o0
- bg L0
- nop
- add %o3,%g0, %o7
- retl
- nop
-
-b_call_imm:
- sethi %hi(b_null),%o4
- or %o4,%lo(b_null),%o4
- add %o7,%g0, %o3
-L1:
- call b_null
- call b_null
- call b_null
- call b_null
- call b_null
-
- subcc %o0,1,%o0
- bg L0
- nop
- add %o3,%g0, %o7
- retl
- nop
-
-
-b_add:
- add %o0,%g0,%o1
- add %o0,%g0,%o2
- add %o0,%g0,%o3
- add %o0,%g0,%o4
-L2:
- sub %o0,5,%o0
- sub %o1,5,%o1
- sub %o2,5,%o2
- sub %o3,5,%o3
- sub %o4,5,%o4
-
- subcc %o0,5,%o0
- sub %o1,5,%o1
- sub %o2,5,%o2
- sub %o3,5,%o3
- sub %o4,5,%o4
-
- bg L2
- nop
- retl
- nop
-
-
-b_load:
- ld [%sp+ 0], %g0
-L3:
- ld [%sp+ 4],%g0
- ld [%sp+ 8],%g0
- ld [%sp+12],%g0
- ld [%sp+16],%g0
- ld [%sp+20],%g0
- ld [%sp+24],%g0
- ld [%sp+28],%g0
- ld [%sp+32],%g0
- ld [%sp+36],%g0
-
- subcc %o0,10,%o0
- bg L3
- ld [%sp+ 0],%g0
- retl
- nop
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-#ifndef QT_VAX_H
-#define QT_VAX_H
-
-typedef unsigned long qt_word_t;
-
-/* Thread's initial stack layout on the VAX:
-
- non-varargs:
-
- +---
- | arg[2] === `userf' on startup
- | arg[1] === `pt' on startup
- | arg[0] === `pu' on startup
- | ... === `only' on startup.
- +---
- | ret pc === `qt_start' on startup
- | fp === 0 on startup
- | ap === 0 on startup
- | <mask>
- | 0 (handler) <--- qt_t.sp
- +---
-
- When a non-varargs thread is started, it ``returns'' to the start
- routine, which calls the client's `only' function.
-
- The varargs case is clearly bad code. The various values should be
- stored in a save area and snarfed in to callee-save registers on
- startup. However, it's too painful to figure out the register
- mask (right now), so do it the slow way.
-
- +---
- | arg[n-1]
- | ..
- | arg[0]
- | nargs
- +---
- | === `cleanup'
- | === `vuserf'
- | === `startup'
- | === `pt'
- +---
- | ret pc === `qt_start' on startup
- | fp === 0 on startup
- | ap === 0 on startup
- | <mask>
- | 0 (handler) <--- qt_t.sp
- +---
-
- When a varargs thread is started, it ``returns'' to the `qt_vstart'
- startup code. The startup code pops all the extra arguments, then
- calls the appropriate functions. */
-
-
-/* What to do to start a thread running. */
-extern void qt_start (void);
-extern void qt_vstart (void);
-
-
-/* Initial call frame for non-varargs and varargs cases. */
-#define QT_STKBASE (10 * 4)
-#define QT_VSTKBASE (9 * 4)
-
-
-/* Stack "must be" 4-byte aligned. (Actually, no, but it's
- easiest and probably fastest to do so.) */
-
-#define QT_STKALIGN (4)
-
-
-/* Where to place various arguments. */
-#define QT_ONLY_INDEX (5)
-#define QT_USER_INDEX (8)
-#define QT_ARGT_INDEX (7)
-#define QT_ARGU_INDEX (6)
-
-#define QT_VSTARTUP_INDEX (6)
-#define QT_VUSERF_INDEX (7)
-#define QT_VCLEANUP_INDEX (8)
-#define QT_VARGT_INDEX (5)
-
-
-/* Stack grows down. The top of the stack is the first thing to
- pop off (predecrement, postincrement). */
-#define QT_GROW_DOWN
-
-
-extern void qt_error (void);
-
-#define QT_VAX_GMASK_NOREGS (0)
-
-/* Push on the error return address, null termination to call chains,
- number of arguments to `only', register save mask (save no
- registers). */
-
-#define QT_ARGS_MD(sto) \
- (QT_SPUT (sto, 0, 0), \
- QT_SPUT (sto, 1, QT_VAX_GMASK_NOREGS), \
- QT_SPUT (sto, 2, 0), \
- QT_SPUT (sto, 3, 0), \
- QT_SPUT (sto, 4, qt_start))
-
-#define QT_VARGS_MD0(sto, nbytes) \
- (QT_SPUT (sto, (-(nbytes)/4)-1, (nbytes)/4), \
- ((char *)(((sto)-4) - QT_STKROUNDUP(nbytes))))
-
-#define QT_VARGS_ADJUST(sp) ((char *)sp + 4)
-
-#define QT_VARGS_MD1(sto) \
- (QT_SPUT (sto, 0, 0), \
- QT_SPUT (sto, 1, QT_VAX_GMASK_NOREGS), \
- QT_SPUT (sto, 2, 0), \
- QT_SPUT (sto, 3, 0), \
- QT_SPUT (sto, 4, qt_vstart))
-
-#define QT_VARGS_DEFAULT
-
-#endif /* QT_VAX_H */
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
- .text
-
- .globl _qt_abort
- .globl _qt_block
- .globl _qt_blocki
- .globl _qt_start
- .globl _qt_vstart
-
-
-/*
-// Calls to these routines have the signature
-//
-// void *block (func, arg1, arg2, newsp)
-//
-// Since the prologue saves 5 registers, nargs, pc, fp, ap, mask, and
-// a condition handler (at sp+0), the first argument is 40=4*10 bytes
-// offset from the stack pointer.
-*/
-_qt_block:
-_qt_blocki:
-_qt_abort:
- .word 0x7c0 /* Callee-save mask: 5 registers. */
- movl 56(sp),r1 /* Get stack pointer of new thread. */
- movl 52(sp),-(r1) /* Push arg2 */
- movl 48(sp),-(r1) /* Push arg1 */
- movl sp,-(r1) /* Push arg0 */
-
- movl 44(sp),r0 /* Get helper to call. */
- movl r1,sp /* Move to new thread's stack. */
- addl3 sp,$12,fp /* .. including the frame pointer. */
- calls $3,(r0) /* Call helper. */
-
- ret
-
-_qt_start:
- movl (sp)+,r0 /* Get `only'. */
- calls $3,(r0) /* Call `only'. */
- calls $0,_qt_error /* `only' erroniously returned. */
-
-
-_qt_vstart:
- movl (sp)+,r10 /* Get `pt'. */
- movl (sp)+,r9 /* Get `startup'. */
- movl (sp)+,r8 /* Get `vuserf'. */
- movl (sp)+,r7 /* Get `cleanup'. */
-
- pushl r10 /* Push `qt'. */
- calls $1,(r9) /* Call `startup', pop `qt' on return. */
-
- calls (sp)+,(r8) /* Call user's function. */
-
- pushl r0 /* Push `vuserf_retval'. */
- pushl r10 /* Push `qt'. */
- calls $2,(r7) /* Call `cleanup', never return. */
-
- calls $0,_qt_error /* `cleanup' erroniously returned. */
+++ /dev/null
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
- .text
- .globl _b_call_reg
- .globl _b_call_imm
- .globl _b_add
- .globl _b_load
-
-_b_null:
- .word 0x0
- ret
-
-_b_call_reg:
- .word 0x0
- movl 4(ap),r0
- moval _b_null,r1
-L0:
- calls $0,(r1)
- calls $0,(r1)
- calls $0,(r1)
- calls $0,(r1)
- calls $0,(r1)
-
- subl2 $5,r0
- bgtr L0
- ret
-
-
-_b_call_imm:
- .word 0x0
- movl 4(ap),r0
-L1:
- calls $0,_b_null
- calls $0,_b_null
- calls $0,_b_null
- calls $0,_b_null
- calls $0,_b_null
-
- subl2 $5,r0
- bgtr L1
- ret
-
-
-_b_add:
- .word 0x0
- movl 4(ap),r0
-L2:
- subl2 $1,r0
- subl2 $1,r0
- subl2 $1,r0
- subl2 $1,r0
- subl2 $1,r0
-
- subl2 $1,r0
- subl2 $1,r0
- subl2 $1,r0
- subl2 $1,r0
- subl2 $1,r0
-
- bgtr L2
- ret
-
-
-_b_load:
- .word 0x0
- movl 4(ap),r0
-L3:
- movl 0(sp),r1
- movl 4(sp),r1
- movl 8(sp),r1
- movl 12(sp),r1
- movl 16(sp),r1
- movl 20(sp),r1
- movl 24(sp),r1
- movl 28(sp),r1
- movl 32(sp),r1
- movl 36(sp),r1
-
- subl2 $1,r0
- bgtr L3
- ret
+++ /dev/null
-/* meas.c -- measure qt stuff. */
-
-#include "copyright.h"
-
-/* Need this to get assertions under Mach on the Sequent/i386: */
-#ifdef __i386__
-#define assert(ex) \
- do { \
- if (!(ex)) { \
- fprintf (stderr, "[%s:%d] Assertion " #ex " failed\n", __FILE__, __LINE__); \
- abort(); \
- } \
- } while (0)
-#else
-#include <assert.h>
-#endif
-
-/* This really ought to be defined in some ANSI include file (*I*
- think...), but it's defined here instead, which leads us to another
- machine dependency.
-
- The `iaddr_t' type is an integer representation of a pointer,
- suited for doing arithmetic on addresses, e.g. to round an address
- to an alignment boundary. */
-typedef unsigned long iaddr_t;
-
-#include <stdarg.h> /* For varargs tryout. */
-#include <stdio.h>
-#include "b.h"
-#include "qt.h"
-#include "stp.h"
-
-extern void exit (int status);
-extern int atoi (char const *s);
-extern int fprintf (FILE *out, char const *fmt, ...);
-extern int fputs (char const *s, FILE *fp);
-extern void free (void *sto);
-extern void *malloc (unsigned nbytes);
-extern void perror (char const *s);
-
-void usage (void);
-void tracer(void);
-
-/* Round `v' to be `a'-aligned, assuming `a' is a power of two. */
-#define ROUND(v, a) (((v) + (a) - 1) & ~((a)-1))
-
-typedef struct thread_t {
- qt_t *qt; /* Pointer to thread of function... */
- void *stk;
- void *top; /* Set top of stack if reuse. */
- struct thread_t *next;
-} thread_t;
-
-
- static thread_t *
-t_alloc (void)
-{
- thread_t *t;
- int ssz = 0x1000;
-
- t = malloc (sizeof(thread_t));
- if (!t) {
- perror ("malloc");
- exit (1);
- }
- assert (ssz > QT_STKBASE);
- t->stk = malloc (ssz);
- t->stk = (void *)ROUND (((iaddr_t)t->stk), QT_STKALIGN);
- if (!t->stk) {
- perror ("malloc");
- exit (1);
- }
- assert ((((iaddr_t)t->stk) & (QT_STKALIGN-1)) == 0);
- t->top = QT_SP (t->stk, ssz - QT_STKBASE);
-
- return (t);
-}
-
-
- static thread_t *
-t_create (qt_only_t *starter, void *p0, qt_userf_t *f)
-{
- thread_t *t;
-
- t = t_alloc();
- t->qt = QT_ARGS (t->top, p0, t, f, starter);
- return (t);
-}
-
-
- static void
-t_free (thread_t *t)
-{
- free (t->stk);
- free (t);
-}
-
-
- static void *
-t_null (qt_t *old, void *p1, void *p2)
-{
- /* return (garbage); */
-}
-
-
- static void *
-t_splat (qt_t *old, void *oldp, void *null)
-{
- *(qt_t **)oldp = old;
- /* return (garbage); */
-}
-
-
-static char const test01_msg[] =
- "*QT_SP(sto,sz), QT_ARGS(top,p0,p1,userf,first)";
-
-static char const *test01_descr[] = {
- "Performs 1 QT_SP and one QT_ARGS per iteration.",
- NULL
-};
-
-/* This test gives a guess on how long it takes to initalize
- a thread. */
-
- static void
-test01 (int n)
-{
- char stack[QT_STKBASE+QT_STKALIGN];
- char *stk;
- qt_t *top;
-
- stk = (char *)ROUND (((iaddr_t)stack), QT_STKALIGN);
-
- {
- int i;
-
- for (i=0; i<QT_STKBASE; ++i) {
- stk[i] = 0;
- }
- }
-
- while (n>0) {
- /* RETVALUSED */
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
-#ifdef NDEF
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
-
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
- top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
-
- n -= 10;
-#else
- n -= 1;
-#endif
- }
-}
-
-
-static char const test02_msg[] = "QT_BLOCKI (0, 0, test02_aux, t->qt)";
-static qt_t *rootthread;
-
- static void
-test02_aux1 (void *pu, void *pt, qt_userf_t *f)
-{
- QT_ABORT (t_null, 0, 0, rootthread);
-}
-
- static void *
-test02_aux2 (qt_t *old, void *farg1, void *farg2)
-{
- rootthread = old;
- /* return (garbage); */
-}
-
- static void
-test02 (int n)
-{
- thread_t *t;
-
- while (n>0) {
- t = t_create (test02_aux1, 0, 0);
- QT_BLOCKI (test02_aux2, 0, 0, t->qt);
- t_free (t);
- t = t_create (test02_aux1, 0, 0);
- QT_BLOCKI (test02_aux2, 0, 0, t->qt);
- t_free (t);
- t = t_create (test02_aux1, 0, 0);
- QT_BLOCKI (test02_aux2, 0, 0, t->qt);
- t_free (t);
- t = t_create (test02_aux1, 0, 0);
- QT_BLOCKI (test02_aux2, 0, 0, t->qt);
- t_free (t);
- t = t_create (test02_aux1, 0, 0);
- QT_BLOCKI (test02_aux2, 0, 0, t->qt);
- t_free (t);
-
- n -= 5;
- }
-}
-
-
-static char const test03_msg[] = "QT_BLOCKI (...) test vals are right.";
-
-
-/* Called by the thread function when it wants to shut down.
- Return a value to the main thread. */
-
- static void *
-test03_aux0 (qt_t *old_is_garbage, void *farg1, void *farg2)
-{
- assert (farg1 == (void *)5);
- assert (farg2 == (void *)6);
- return ((void *)15); /* Some unlikely value. */
-}
-
-
-/* Called during new thread startup by main thread. Since the new
- thread has never run before, return value is ignored. */
-
- static void *
-test03_aux1 (qt_t *old, void *farg1, void *farg2)
-{
- assert (old != NULL);
- assert (farg1 == (void *)5);
- assert (farg2 == (void *)6);
- rootthread = old;
- return ((void *)16); /* Different than `15'. */
-}
-
- static void
-test03_aux2 (void *pu, void *pt, qt_userf_t *f)
-{
- assert (pu == (void *)1);
- assert (f == (qt_userf_t *)4);
- QT_ABORT (test03_aux0, (void *)5, (void *)6, rootthread);
-}
-
- static void
-test03 (int n)
-{
- thread_t *t;
- void *rv;
-
- while (n>0) {
- t = t_create (test03_aux2, (void *)1, (qt_userf_t *)4);
- rv = QT_BLOCKI (test03_aux1, (void *)5, (void *)6, t->qt);
- assert (rv == (void *)15);
- t_free (t);
-
- --n;
- }
-}
-
-
-static char const test04_msg[] = "stp_start w/ no threads.";
-
- static void
-test04 (int n)
-{
- while (n>0) {
- stp_init(); stp_start();
- stp_init(); stp_start();
- stp_init(); stp_start();
- stp_init(); stp_start();
- stp_init(); stp_start();
-
- stp_init(); stp_start();
- stp_init(); stp_start();
- stp_init(); stp_start();
- stp_init(); stp_start();
- stp_init(); stp_start();
-
- n -= 10;
- }
-}
-
-
-static char const test05_msg[] = "stp w/ 2 yielding thread.";
-
- static void
-test05_aux (void *null)
-{
- stp_yield();
- stp_yield();
-}
-
- static void
-test05 (int n)
-{
- while (n>0) {
- stp_init();
- stp_create (test05_aux, 0);
- stp_create (test05_aux, 0);
- stp_start();
-
- --n;
- }
-}
-
-
-static char const test06_msg[] = "*QT_ARGS(...), QT_BLOCKI one thread";
-
-static char const *test06_descr[] = {
- "Does a QT_ARGS, QT_BLOCKI to a helper function that saves the",
- "stack pointer of the main thread, calls an `only' function that",
- "saves aborts the thread, calling a null helper function.",
- ":: start/stop = QT_ARGS + QT_BLOCKI + QT_ABORT + 3 procedure calls.",
- NULL
-};
-
-/* This test initializes a thread, runs it, then returns to the main
- program, which reinitializes the thread, runs it again, etc. Each
- iteration corresponds to 1 init, 1 abort, 1 block. */
-
-static qt_t *test06_sp;
-
-
- static void
-test06_aux2 (void *null0a, void *null1b, void *null2b, qt_userf_t *null)
-{
- QT_ABORT (t_null, 0, 0, test06_sp);
-}
-
-
- static void *
-test06_aux3 (qt_t *sp, void *null0c, void *null1c)
-{
- test06_sp = sp;
- /* return (garbage); */
-}
-
-
- static void
-test06 (int n)
-{
- thread_t *t;
-
- t = t_create (0, 0, 0);
-
- while (n>0) {
- /* RETVALUSED */
- QT_ARGS (t->top, 0, 0, 0, test06_aux2);
- QT_BLOCKI (test06_aux3, 0, 0, t->qt);
-#ifdef NDEF
- /* RETVALUSED */
- QT_ARGS (t->top, 0, 0, 0, test06_aux2);
- QT_BLOCKI (test06_aux3, 0, 0, t->qt);
-
- /* RETVALUSED */
- QT_ARGS (t->top, 0, 0, 0, test06_aux2);
- QT_BLOCKI (test06_aux3, 0, 0, t->qt);
-
- /* RETVALUSED */
- QT_ARGS (t->top, 0, 0, 0, test06_aux2);
- QT_BLOCKI (test06_aux3, 0, 0, t->qt);
-
- /* RETVALUSED */
- QT_ARGS (t->top, 0, 0, 0, test06_aux2);
- QT_BLOCKI (test06_aux3, 0, 0, t->qt);
-
- n -= 5;
-#else
- --n;
-#endif
- }
-}
-
-static char test07_msg[] = "*cswap between threads";
-
-static char const *test07_descr[] = {
- "Build a chain of threads where each thread has a fixed successor.",
- "There is no scheduling performed. Each thread but one is a loop",
- "that simply blocks with QT_BLOCKI, calling a helper that saves the",
- "current stack pointer. The last thread decrements a count, and,",
- "if zero, aborts back to the main thread. Else it continues with",
- "the blocking chain. The count is divided by the number of threads",
- "in the chain, so `n' is the number of integer block operations.",
- ":: integer cswap = QT_BLOCKI + a procedure call.",
- NULL
-};
-
-/* This test repeatedly blocks a bunch of threads.
- Each iteration corresponds to one block operation.
-
- The threads are arranged so that there are TEST07_N-1 of them that
- run `test07_aux2'. Each one of those blocks saving it's sp to
- storage owned by the preceding thread; a pointer to that storage is
- passed in via `mep'. Each thread has a handle on it's own storage
- for the next thread, referenced by `nxtp', and it blocks by passing
- control to `*nxtp', telling the helper function to save its state
- in `*mep'. The last thread in the chain decrements a count and, if
- it's gone below zero, returns to `test07'; otherwise, it invokes
- the first thread in the chain. */
-
-static qt_t *test07_heavy;
-
-#define TEST07_N (4)
-
-
- static void
-test07_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null)
-{
- qt_t *nxt;
-
- while (1) {
- nxt = *(qt_t **)nxtp;
-#ifdef NDEF
- printf ("Helper 0x%p\n", nxtp);
-#endif
- QT_BLOCKI (t_splat, mep, 0, nxt);
- }
-}
-
- static void
-test07_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null)
-{
- int n;
-
- n = *(int *)np;
- while (1) {
- n -= TEST07_N;
- if (n<0) {
- QT_ABORT (t_splat, mep, 0, test07_heavy);
- }
- QT_BLOCKI (t_splat, mep, 0, *(qt_t **)nxtp);
- }
-}
-
-
- static void
-test07 (int n)
-{
- int i;
- thread_t *t[TEST07_N];
-
- for (i=0; i<TEST07_N; ++i) {
- t[i] = t_create (0, 0, 0);
- }
- for (i=0; i<TEST07_N-1; ++i) {
- /* RETVALUSED */
- QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test07_aux2);
- }
- /* RETVALUSED */
- QT_ARGS (t[i]->top, &n, &t[TEST07_N-1]->qt, &t[0]->qt, test07_aux3);
- QT_BLOCKI (t_splat, &test07_heavy, 0, t[0]->qt);
-}
-
-
-static char test08_msg[] = "Floating-point cswap between threads";
-
-static char const *test08_descr[] = {
- "Measure context switch times including floating-point, use QT_BLOCK.",
- NULL
-};
-
-static qt_t *test08_heavy;
-
-#define TEST08_N (4)
-
-
- static void
-test08_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null)
-{
- qt_t *nxt;
-
- while (1) {
- nxt = *(qt_t **)nxtp;
- QT_BLOCK (t_splat, mep, 0, nxt);
- }
-}
-
- static void
-test08_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null)
-{
- int n;
-
- n = *(int *)np;
- while (1) {
- n -= TEST08_N;
- if (n<0) {
- QT_ABORT (t_splat, mep, 0, test08_heavy);
- }
- QT_BLOCK (t_splat, mep, 0, *(qt_t **)nxtp);
- }
-}
-
-
- static void
-test08 (int n)
-{
- int i;
- thread_t *t[TEST08_N];
-
- for (i=0; i<TEST08_N; ++i) {
- t[i] = t_create (0, 0, 0);
- }
- for (i=0; i<TEST08_N-1; ++i) {
- /* RETVALUSED */
- QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test08_aux2);
- }
- /* RETVALUSED */
- QT_ARGS (t[i]->top, &n, &t[TEST08_N-1]->qt, &t[0]->qt, test08_aux3);
- QT_BLOCK (t_splat, &test08_heavy, 0, t[0]->qt);
-}
-
-
-/* Test the varargs procedure calling. */
-
-char const test09_msg[] = { "Start and run threads using varargs." };
-
-thread_t *test09_t0, *test09_t1, *test09_t2, *test09_main;
-
- thread_t *
-test09_create (qt_startup_t *start, qt_vuserf_t *f,
- qt_cleanup_t *cleanup, int nbytes, ...)
-{
- va_list ap;
- thread_t *t;
-
- t = t_alloc();
- va_start (ap, nbytes);
- t->qt = QT_VARGS (t->top, nbytes, ap, t, start, f, cleanup);
- va_end (ap);
- return (t);
-}
-
-
- static void
-test09_cleanup (void *pt, void *vuserf_retval)
-{
- assert (vuserf_retval == (void *)17);
- QT_ABORT (t_splat, &((thread_t *)pt)->qt, 0,
- ((thread_t *)pt)->next->qt);
-}
-
-
- static void
-test09_start (void *pt)
-{
-}
-
-
- static void *
-test09_user0 (void)
-{
- QT_BLOCKI (t_splat, &test09_t0->qt, 0, test09_t1->qt);
- return ((void *)17);
-}
-
- static void *
-test09_user2 (int one, int two)
-{
- assert (one == 1);
- assert (two == 2);
- QT_BLOCKI (t_splat, &test09_t1->qt, 0, test09_t2->qt);
- assert (one == 1);
- assert (two == 2);
- return ((void *)17);
-}
-
- static void *
-test09_user10 (int one, int two, int three, int four, int five,
- int six, int seven, int eight, int nine, int ten)
-{
- assert (one == 1);
- assert (two == 2);
- assert (three == 3);
- assert (four == 4);
- assert (five == 5);
- assert (six == 6);
- assert (seven == 7);
- assert (eight == 8);
- assert (nine == 9);
- assert (ten == 10);
- QT_BLOCKI (t_splat, &test09_t2->qt, 0, test09_main->qt);
- assert (one == 1);
- assert (two == 2);
- assert (three == 3);
- assert (four == 4);
- assert (five == 5);
- assert (six == 6);
- assert (seven == 7);
- assert (eight == 8);
- assert (nine == 9);
- assert (ten == 10);
- return ((void *)17);
-}
-
-
- void
-test09 (int n)
-{
- thread_t main;
-
- test09_main = &main;
-
- while (--n >= 0) {
- test09_t0 = test09_create (test09_start, (qt_vuserf_t*)test09_user0,
- test09_cleanup, 0);
- test09_t1 = test09_create (test09_start, (qt_vuserf_t*)test09_user2,
- test09_cleanup, 2 * sizeof(qt_word_t), 1, 2);
- test09_t2 = test09_create (test09_start, (qt_vuserf_t*)test09_user10,
- test09_cleanup, 10 * sizeof(qt_word_t),
- 1, 2, 3, 4, 5, 6, 7, 8, 9, 10);
-
- /* Chaining used by `test09_cleanup' to determine who is next. */
- test09_t0->next = test09_t1;
- test09_t1->next = test09_t2;
- test09_t2->next = test09_main;
-
- QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt);
- QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt);
-
- t_free (test09_t0);
- t_free (test09_t1);
- t_free (test09_t2);
- }
-}
-
-
-\f/* Test 10/11/12: time the cost of various number of args. */
-
-char const test10_msg[] = { "*Test varargs init & startup w/ 0 args." };
-
-char const *test10_descr[] = {
- "Start and stop threads that use variant argument lists (varargs).",
- "Each thread is initialized by calling a routine that calls",
- "QT_VARARGS. Then runs the thread by calling QT_BLOCKI to hald the",
- "main thread, a helper that saves the main thread's stack pointer,",
- "a null startup function, a null user function, a cleanup function",
- "that calls QT_ABORT and restarts the main thread. Copies no user",
- "parameters.",
- ":: varargs start/stop = QT_BLOCKI + QT_ABORT + 6 function calls.",
- NULL
-};
-
-/* Helper function to send control back to main.
- Don't save anything. */
-
-
-/* Helper function for starting the varargs thread. Save the stack
- pointer of the main thread so we can get back there eventually. */
-
-
-/* Startup function for a varargs thread. */
-
- static void
-test10_startup (void *pt)
-{
-}
-
-
-/* User function for a varargs thread. */
-
- static void *
-test10_run (int arg0, ...)
-{
- /* return (garbage); */
-}
-
-
-/* Cleanup function for a varargs thread. Send control
- back to the main thread. Don't save any state from the thread that
- is halting. */
-
- void
-test10_cleanup (void *pt, void *vuserf_retval)
-{
- QT_ABORT (t_null, 0, 0, ((thread_t *)pt)->qt);
-}
-
-
- void
-test10_init (thread_t *new, thread_t *next, int nbytes, ...)
-{
- va_list ap;
-
- va_start (ap, nbytes);
- new->qt = QT_VARGS (new->top, nbytes, ap, next, test10_startup,
- test10_run, test10_cleanup);
- va_end (ap);
-}
-
-
- void
-test10 (int n)
-{
- thread_t main;
- thread_t *t;
-
- t = t_alloc();
- t->next = &main;
-
- while (--n >= 0) {
- test10_init (t, &main, 0);
- QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
- }
- t_free (t);
-}
-
-
-char const test11_msg[] = { "*Test varargs init & startup w/ 2 args." };
-
-char const *test11_descr[] = {
- "Varargs initialization/run. Copies 2 user arguments.",
- ":: varargs 2 start/stop = QT_VARGS(2 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
- NULL
-};
-
-
- void
-test11 (int n)
-{
- thread_t main;
- thread_t *t;
-
- t = t_alloc();
- t->next = &main;
-
- while (--n >= 0) {
- test10_init (t, &main, 2 * sizeof(int), 2, 1);
- QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
- }
- t_free (t);
-}
-
-char const test12_msg[] = { "*Test varargs init & startup w/ 4 args." };
-
-char const *test12_descr[] = {
- "Varargs initialization/run. Copies 4 user arguments.",
- ":: varargs 4 start/stop = QT_VARGS(4 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
- NULL
-};
-
-
- void
-test12 (int n)
-{
- thread_t main;
- thread_t *t;
-
- t = t_alloc();
- t->next = &main;
-
- while (--n >= 0) {
- test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1);
- QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
- }
- t_free (t);
-}
-
-
-char const test13_msg[] = { "*Test varargs init & startup w/ 8 args." };
-
-char const *test13_descr[] = {
- "Varargs initialization/run. Copies 8 user arguments.",
- ":: varargs 8 start/stop = QT_VARGS(8 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
- NULL
-};
-
- void
-test13 (int n)
-{
- thread_t main;
- thread_t *t;
-
- t = t_alloc();
- t->next = &main;
-
- while (--n >= 0) {
- test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1);
- QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
- }
- t_free (t);
-}
-
-
-char const test14_msg[] = { "*Test varargs initialization w/ 0 args." };
-
-char const *test14_descr[] = {
- "Varargs initialization without running the thread. Just calls",
- "QT_VARGS.",
- ":: varargs 0 init = QT_VARGS()",
- NULL
-};
-
- void
-test14 (int n)
-{
- thread_t main;
- thread_t *t;
-
- t = t_alloc();
- t->next = &main;
-
- while (--n >= 0) {
- test10_init (t, &main, 0 * sizeof(int));
- }
- t_free (t);
-}
-
-
-char const test15_msg[] = { "*Test varargs initialization w/ 2 args." };
-
-char const *test15_descr[] = {
- "Varargs initialization without running the thread. Just calls",
- "QT_VARGS.",
- ":: varargs 2 init = QT_VARGS(2 args)",
- NULL
-};
-
- void
-test15 (int n)
-{
- thread_t main;
- thread_t *t;
-
- t = t_alloc();
- t->next = &main;
-
- while (--n >= 0) {
- test10_init (t, &main, 2 * sizeof(int), 2, 1);
- }
- t_free (t);
-}
-
-char const test16_msg[] = { "*Test varargs initialization w/ 4 args." };
-
-char const *test16_descr[] = {
- "Varargs initialization without running the thread. Just calls",
- "QT_VARGS.",
- ":: varargs 4 init = QT_VARGS(4 args)",
- NULL
-};
-
-
- void
-test16 (int n)
-{
- thread_t main;
- thread_t *t;
-
- t = t_alloc();
- t->next = &main;
-
- while (--n >= 0) {
- test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1);
- }
- t_free (t);
-}
-
-
-char const test17_msg[] = { "*Test varargs initialization w/ 8 args." };
-
-char const *test17_descr[] = {
- "Varargs initialization without running the thread. Just calls",
- "QT_VARGS.",
- ":: varargs 8 init = QT_VARGS(8 args)",
- NULL
-};
-
-
- void
-test17 (int n)
-{
- thread_t main;
- thread_t *t;
-
- t = t_alloc();
- t->next = &main;
-
- while (--n >= 0) {
- test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1);
- }
- t_free (t);
-}
-
-\f/* Test times for basic machine operations. */
-
-char const test18_msg[] = { "*Call register indirect." };
-char const *test18_descr[] = { NULL };
-
- void
-test18 (int n)
-{
- b_call_reg (n);
-}
-
-
-char const test19_msg[] = { "*Call immediate." };
-char const *test19_descr[] = { NULL };
-
- void
-test19 (int n)
-{
- b_call_imm (n);
-}
-
-
-char const test20_msg[] = { "*Add register-to-register." };
-char const *test20_descr[] = { NULL };
-
- void
-test20 (int n)
-{
- b_add (n);
-}
-
-
-char const test21_msg[] = { "*Load memory to a register." };
-char const *test21_descr[] = { NULL };
-
- void
-test21 (int n)
-{
- b_load (n);
-}
-
-\f/* Driver. */
-
-typedef struct foo_t {
- char const *msg; /* Message to print for generic help. */
- char const **descr; /* A description of what is done by the test. */
- void (*f)(int n);
-} foo_t;
-
-
-static foo_t foo[] = {
- { "Usage:\n", NULL, (void(*)(int n))usage },
- { test01_msg, test01_descr, test01 },
- { test02_msg, NULL, test02 },
- { test03_msg, NULL, test03 },
- { test04_msg, NULL, test04 },
- { test05_msg, NULL, test05 },
- { test06_msg, test06_descr, test06 },
- { test07_msg, test07_descr, test07 },
- { test08_msg, test08_descr, test08 },
- { test09_msg, NULL, test09 },
- { test10_msg, test10_descr, test10 },
- { test11_msg, test11_descr, test11 },
- { test12_msg, test12_descr, test12 },
- { test13_msg, test13_descr, test13 },
- { test14_msg, test14_descr, test14 },
- { test15_msg, test15_descr, test15 },
- { test16_msg, test16_descr, test16 },
- { test17_msg, test17_descr, test17 },
- { test18_msg, test18_descr, test18 },
- { test19_msg, test19_descr, test19 },
- { test20_msg, test20_descr, test20 },
- { test21_msg, test21_descr, test21 },
- { 0, 0 }
-};
-
-static int tv = 0;
-
- void
-tracer ()
-{
-
- fprintf (stderr, "tracer\t%d\n", tv++);
- fflush (stderr);
-}
-
- void
-tracer2 (void *val)
-{
- fprintf (stderr, "tracer2\t%d val=0x%p", tv++, val);
- fflush (stderr);
-}
-
-
- void
-describe()
-{
- int i;
- FILE *out = stdout;
-
- for (i=0; foo[i].msg; ++i) {
- if (foo[i].descr) {
- int j;
-
- putc ('\n', out);
- fprintf (out, "[%d]\n", i);
- for (j=0; foo[i].descr[j]; ++j) {
- fputs (foo[i].descr[j], out);
- putc ('\n', out);
- }
- }
- }
- exit (0);
-}
-
-
- void
-usage()
-{
- int i;
-
- fputs (foo[0].msg, stderr);
- for (i=1; foo[i].msg; ++i) {
- fprintf (stderr, "%2d\t%s\n", i, foo[i].msg);
- }
- exit (1);
-}
-
-
- void
-args (int *which, int *n, int argc, char **argv)
-{
- static int nfuncs = 0;
-
- if (argc == 2 && argv[1][0] == '-' && argv[1][1] == 'h') {
- describe();
- }
-
- if (nfuncs == 0) {
- for (nfuncs=0; foo[nfuncs].msg; ++nfuncs)
- ;
- }
-
- if (argc != 2 && argc != 3) {
- usage();
- }
-
- *which = atoi (argv[1]);
- if (*which < 0 || *which >= nfuncs) {
- usage();
- }
- *n = (argc == 3)
- ? atoi (argv[2])
- : 1;
-}
-
-
- int
-main (int argc, char **argv)
-{
- int which, n;
- args (&which, &n, argc, argv);
- (*(foo[which].f))(n);
- exit (0);
- return (0);
-}
+++ /dev/null
-#include "qt/copyright.h"
-#include "qt/qt.h"
-
-#ifdef QT_VARGS_DEFAULT
-
-/* If the stack grows down, `vargs' is a pointer to the lowest
- address in the block of arguments. If the stack grows up, it is a
- pointer to the highest address in the block. */
-
- qt_t *
-qt_vargs (qt_t *sp, int nbytes, void *vargs,
- void *pt, qt_startup_t *startup,
- qt_vuserf_t *vuserf, qt_cleanup_t *cleanup)
-{
- int i;
-
- sp = QT_VARGS_MD0 (sp, nbytes);
-#ifdef QT_GROW_UP
- for (i=nbytes/sizeof(qt_word_t); i>0; --i) {
- QT_SPUT (QT_VARGS_ADJUST(sp), i, ((qt_word_t *)vargs)[-i]);
- }
-#else
- for (i=nbytes/sizeof(qt_word_t); i>0; --i) {
- QT_SPUT (QT_VARGS_ADJUST(sp), i-1, ((qt_word_t *)vargs)[i-1]);
- }
-#endif
-
- QT_VARGS_MD1 (QT_VADJ(sp));
- QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
- QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
- QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
- QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
- return ((qt_t *)QT_VADJ(sp));
-}
-#endif /* def QT_VARGS_DEFAULT */
-
- void
-qt_null (void)
-{
-}
-
- void
-qt_error (void)
-{
- extern void abort(void);
-
- abort();
-}
+++ /dev/null
-#ifndef QT_H
-#define QT_H
-
-#if defined (QT_IMPORT)
-# define QT_API __declspec (dllimport) extern
-#elif defined (QT_EXPORT) || defined (DLL_EXPORT)
-# define QT_API __declspec (dllexport) extern
-#else
-# define QT_API extern
-#endif
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-#include <qt/@qtmd_h@>
-
-
-/* A QuickThreads thread is represented by it's current stack pointer.
- To restart a thread, you merely need pass the current sp (qt_t*) to
- a QuickThreads primitive. `qt_t*' is a location on the stack. To
- improve type checking, represent it by a particular struct. */
-
-typedef struct qt_t {
- char dummy;
-} qt_t;
-
-
-/* Alignment is guaranteed to be a power of two. */
-#ifndef QT_STKALIGN
- #error "Need to know the machine-dependent stack alignment."
-#endif
-
-#define QT_STKROUNDUP(bytes) \
- (((bytes)+QT_STKALIGN) & ~(QT_STKALIGN-1))
-
-
-/* Find ``top'' of the stack, space on the stack. */
-#ifndef QT_SP
-#ifdef QT_GROW_DOWN
-#define QT_SP(sto, size) ((qt_t *)(&((char *)(sto))[(size)]))
-#endif
-#ifdef QT_GROW_UP
-#define QT_SP(sto, size) ((void *)(sto))
-#endif
-#if !defined(QT_SP)
- #error "QT_H: Stack must grow up or down!"
-#endif
-#endif
-
-
-/* The type of the user function:
- For non-varargs, takes one void* function.
- For varargs, takes some number of arguments. */
-typedef void *(qt_userf_t)(void *pu);
-typedef void *(qt_vuserf_t)(int arg0, ...);
-
-/* For non-varargs, just call a client-supplied function,
- it does all startup and cleanup, and also calls the user's
- function. */
-typedef void (qt_only_t)(void *pu, void *pt, qt_userf_t *userf);
-
-/* For varargs, call `startup', then call the user's function,
- then call `cleanup'. */
-typedef void (qt_startup_t)(void *pt);
-typedef void (qt_cleanup_t)(void *pt, void *vuserf_return);
-
-
-/* Internal helper for putting stuff on stack. */
-#ifndef QT_SPUT
-#define QT_SPUT(top, at, val) \
- (((qt_word_t *)(top))[(at)] = (qt_word_t)(val))
-#endif
-
-
-/* Push arguments for the non-varargs case. */
-#ifndef QT_ARGS
-
-#ifndef QT_ARGS_MD
-#define QT_ARGS_MD (0)
-#endif
-
-#ifndef QT_STKBASE
- #error "Need to know the machine-dependent stack allocation."
-#endif
-
-/* All things are put on the stack relative to the final value of
- the stack pointer. */
-#ifdef QT_GROW_DOWN
-#define QT_ADJ(sp) (((char *)sp) - QT_STKBASE)
-#else
-#define QT_ADJ(sp) (((char *)sp) + QT_STKBASE)
-#endif
-
-#define QT_ARGS(sp, pu, pt, userf, only) \
- (QT_ARGS_MD (QT_ADJ(sp)), \
- QT_SPUT (QT_ADJ(sp), QT_ONLY_INDEX, only), \
- QT_SPUT (QT_ADJ(sp), QT_USER_INDEX, userf), \
- QT_SPUT (QT_ADJ(sp), QT_ARGT_INDEX, pt), \
- QT_SPUT (QT_ADJ(sp), QT_ARGU_INDEX, pu), \
- ((qt_t *)QT_ADJ(sp)))
-
-#endif
-
-
-/* Push arguments for the varargs case.
- Has to be a function call because initialization is an expression
- and we need to loop to copy nbytes of stuff on to the stack.
- But that's probably OK, it's not terribly cheap, anyway. */
-
-#ifdef QT_VARGS_DEFAULT
-#ifndef QT_VARGS_MD0
-#define QT_VARGS_MD0(sp, vasize) (sp)
-#endif
-#ifndef QT_VARGS_MD1
-#define QT_VARGS_MD1(sp) do { ; } while (0)
-#endif
-
-#ifndef QT_VSTKBASE
- #error "Need base stack size for varargs functions."
-#endif
-
-/* Sometimes the stack pointer needs to munged a bit when storing
- the list of arguments. */
-#ifndef QT_VARGS_ADJUST
-#define QT_VARGS_ADJUST(sp) (sp)
-#endif
-
-/* All things are put on the stack relative to the final value of
- the stack pointer. */
-#ifdef QT_GROW_DOWN
-#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
-#else
-#define QT_VADJ(sp) (((char *)sp) + QT_VSTKBASE)
-#endif
-
-QT_API qt_t *qt_vargs (qt_t *sp, int nbytes, void *vargs,
- void *pt, qt_startup_t *startup,
- qt_vuserf_t *vuserf, qt_cleanup_t *cleanup);
-
-#ifndef QT_VARGS
-#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
- (qt_vargs (sp, nbytes, vargs, pt, startup, vuserf, cleanup))
-#endif
-
-#endif
-
-QT_API void qt_null (void);
-QT_API void qt_error (void);
-
-/* Save the state of the thread and call the helper function
- using the stack of the new thread. */
-typedef void *(qt_helper_t)(qt_t *old, void *a0, void *a1);
-typedef void *(qt_block_t)(qt_helper_t *helper, void *a0, void *a1,
- qt_t *newthread);
-
-/* Rearrange the parameters so that things passed to the helper
- function are already in the right argument registers. */
-#ifndef QT_ABORT
-QT_API void qt_abort (qt_helper_t *h, void *a0, void *a1, qt_t *newthread);
-/* The following does, technically, `return' a value, but the
- user had better not rely on it, since the function never
- returns. */
-#define QT_ABORT(h, a0, a1, newthread) \
- do { qt_abort (h, a0, a1, newthread); } while (0)
-#endif
-
-#ifndef QT_BLOCK
-QT_API void *qt_block (qt_helper_t *h, void *a0, void *a1,
- qt_t *newthread);
-#define QT_BLOCK(h, a0, a1, newthread) \
- (qt_block (h, a0, a1, newthread))
-#endif
-
-#ifndef QT_BLOCKI
-QT_API void *qt_blocki (qt_helper_t *h, void *a0, void *a1,
- qt_t *newthread);
-#define QT_BLOCKI(h, a0, a1, newthread) \
- (qt_blocki (h, a0, a1, newthread))
-#endif
-
-#ifdef __cplusplus
-} /* Match `extern "C" {' at top. */
-#endif
-
-#endif /* ndef QT_H */
+++ /dev/null
-#include "copyright.h"
-#include "qt.h"
-#include "stp.h"
-
-#ifndef NULL
-#define NULL 0
-#endif
-
-#define STP_STKSIZE (0x1000)
-
-/* `alignment' must be a power of 2. */
-#define STP_STKALIGN(sp, alignment) \
- ((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1)))
-
-
-/* The notion of a thread is merged with the notion of a queue.
- Thread stuff: thread status (sp) and stuff to use during
- (re)initialization. Queue stuff: next thread in the queue
- (next). */
-
-struct stp_t {
- qt_t *sp; /* QuickThreads handle. */
- void *sto; /* `malloc'-allocated stack. */
- struct stp_t *next; /* Next thread in the queue. */
-};
-
-
-/* A queue is a circular list of threads. The queue head is a
- designated list element. If this is a uniprocessor-only
- implementation we can store the `main' thread in this, but in a
- multiprocessor there are several `heavy' threads but only one run
- queue. A fancier implementation might have private run queues,
- which would lead to a simpler (trivial) implementation */
-
-typedef struct stp_q_t {
- stp_t t;
- stp_t *tail;
-} stp_q_t;
-
-
-\f/* Helper functions. */
-
-extern void *malloc (unsigned size);
-extern void perror (char const *msg);
-extern void free (void *sto);
-
- void *
-xmalloc (unsigned size)
-{
- void *sto;
-
- sto = malloc (size);
- if (!sto) {
- perror ("malloc");
- exit (1);
- }
- return (sto);
-}
-
-\f/* Queue access functions. */
-
- static void
-stp_qinit (stp_q_t *q)
-{
- q->t.next = q->tail = &q->t;
-}
-
-
- static stp_t *
-stp_qget (stp_q_t *q)
-{
- stp_t *t;
-
- t = q->t.next;
- q->t.next = t->next;
- if (t->next == &q->t) {
- if (t == &q->t) { /* If it was already empty .. */
- return (NULL); /* .. say so. */
- }
- q->tail = &q->t; /* Else now it is empty. */
- }
- return (t);
-}
-
-
- static void
-stp_qput (stp_q_t *q, stp_t *t)
-{
- q->tail->next = t;
- t->next = &q->t;
- q->tail = t;
-}
-
-
-\f/* Thread routines. */
-
-static stp_q_t stp_global_runq; /* A queue of runable threads. */
-static stp_t stp_global_main; /* Thread for the process. */
-static stp_t *stp_global_curr; /* Currently-executing thread. */
-
-static void *stp_starthelp (qt_t *old, void *ignore0, void *ignore1);
-static void stp_only (void *pu, void *pt, qt_userf_t *f);
-static void *stp_aborthelp (qt_t *sp, void *old, void *null);
-static void *stp_yieldhelp (qt_t *sp, void *old, void *blockq);
-
-
- void
-stp_init()
-{
- stp_qinit (&stp_global_runq);
-}
-
-
- void
-stp_start()
-{
- stp_t *next;
-
- while ((next = stp_qget (&stp_global_runq)) != NULL) {
- stp_global_curr = next;
- QT_BLOCK (stp_starthelp, 0, 0, next->sp);
- }
-}
-
-
- static void *
-stp_starthelp (qt_t *old, void *ignore0, void *ignore1)
-{
- stp_global_main.sp = old;
- stp_qput (&stp_global_runq, &stp_global_main);
- /* return (garbage); */
-}
-
-
- void
-stp_create (stp_userf_t *f, void *pu)
-{
- stp_t *t;
- void *sto;
-
- t = xmalloc (sizeof(stp_t));
- t->sto = xmalloc (STP_STKSIZE);
- sto = STP_STKALIGN (t->sto, QT_STKALIGN);
- t->sp = QT_SP (sto, STP_STKSIZE - QT_STKALIGN);
- t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, stp_only);
- stp_qput (&stp_global_runq, t);
-}
-
-
- static void
-stp_only (void *pu, void *pt, qt_userf_t *f)
-{
- stp_global_curr = (stp_t *)pt;
- (*(stp_userf_t *)f)(pu);
- stp_abort();
- /* NOTREACHED */
-}
-
-
- void
-stp_abort (void)
-{
- stp_t *old, *newthread;
-
- newthread = stp_qget (&stp_global_runq);
- old = stp_global_curr;
- stp_global_curr = newthread;
- QT_ABORT (stp_aborthelp, old, (void *)NULL, newthread->sp);
-}
-
-
- static void *
-stp_aborthelp (qt_t *sp, void *old, void *null)
-{
- free (((stp_t *)old)->sto);
- free (old);
- /* return (garbage); */
-}
-
-
- void
-stp_yield()
-{
- stp_t *old, *newthread;
-
- newthread = stp_qget (&stp_global_runq);
- old = stp_global_curr;
- stp_global_curr = newthread;
- QT_BLOCK (stp_yieldhelp, old, &stp_global_runq, newthread->sp);
-}
-
-
- static void *
-stp_yieldhelp (qt_t *sp, void *old, void *blockq)
-{
- ((stp_t *)old)->sp = sp;
- stp_qput ((stp_q_t *)blockq, (stp_t *)old);
- /* return (garbage); */
-}
+++ /dev/null
-#ifndef STP_H
-#define STP_H
-
-/*
- * QuickThreads -- Threads-building toolkit.
- * Copyright (c) 1993 by David Keppel
- *
- * Permission to use, copy, modify and distribute this software and
- * its documentation for any purpose and without fee is hereby
- * granted, provided that the above copyright notice and this notice
- * appear in all copies. This software is provided as a
- * proof-of-concept and for demonstration purposes; there is no
- * representation about the suitability of this software for any
- * purpose.
- */
-
-typedef struct stp_t stp_t;
-
-/* Each thread starts by calling a user-supplied function of this
- type. */
-
-typedef void (stp_userf_t)(void *p0);
-
-/* Call this before any other primitives. */
-extern void stp_init();
-
-/* When one or more threads are created by the main thread,
- the system goes multithread when this is called. It is done
- (no more runable threads) when this returns. */
-
-extern void stp_start (void);
-
-/* Create a thread and make it runable. When the thread starts
- running it will call `f' with the argument `p0'. */
-
-extern void stp_create (stp_userf_t *f, void *p0);
-
-/* The current thread stops running but stays runable.
- It is an error to call `stp_yield' before `stp_start'
- is called or after `stp_start' returns. */
-
-extern void stp_yield (void);
-
-/* Like `stp_yield' but the thread is discarded. Any intermediate
- state is lost. The thread can also terminate by simply
- returning. */
-
-extern void stp_abort (void);
-
-
-#endif /* ndef STP_H */
+++ /dev/null
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 1998, 2006 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE 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, or
-## (at your option) any later version.
-##
-## GUILE 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 GUILE; see the file COPYING.LESSER. If not,
-## write to the Free Software Foundation, Inc., 51 Franklin Street,
-## Fifth Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-EXTRA_DIST = README.time assim cswap go init prim raw
+++ /dev/null
-The program `raw', when run in `..' runs the program `run' produced
-from `meas.c'. It produces a raw output file (see `../tmp/*.raw').
-`raw' will die with an error if run in the current directory. Note
-that some versions of `time' produce output in an unexpected format;
-edit them by hand.
-
-`prim', `init', `cswap' and `go' produce formatted table entries used
-in the documentation (in `../doc'). For example, from `..',
-
- foreach i (tmp/*.raw)
- time/prim $i
- end
-
-See notes in the QuickThreads document about the applicability of
-these microbenchmark measurements -- in general, you can expect all
-QuickThreads operations to be a bit slower when used in a real
-application.
+++ /dev/null
-#! /bin/awk -f
-
-BEGIN {
- nmach = 0;
-
- init_test = "1";
- abort_test = "6";
- blocki_test = "7";
- block_test = "8";
-}
-
-{
- mach = $1
- test = $2
- iter = $3
- time = $6 + $8
-
- if (machi[mach] == 0) {
- machn[nmach] = mach;
- machi[mach] = 1;
- ++nmach;
- }
-
- us_per_op = time / iter * 1000000
- times[mach "_" test] = us_per_op;
-}
-
-
-END {
- for (i=0; i<nmach; ++i) {
- m = machn[i];
- init = times[m "_" init_test];
- printf ("init %s | %f\n", m, init);
-
- init_abort_blocki = times[m "_" abort_test];
- abort_blocki = init_abort_blocki - init;
- blocki = times[m "_" blocki_test];
- abort = abort_blocki - blocki;
- blockf = times[m "_" block_test];
- printf ("swap %s | %f | %f | %f\n", m, abort, blocki, blockf);
- }
-}
+++ /dev/null
-#! /bin/awk -f
-
-BEGIN {
- purpose = "report time used by int only and int+fp cswaps";
-
- nmach = 0;
-
- test_int = "7";
- test_fp = "8";
-}
-
-{
- mach = $1
- test = $2
- iter = $3
- time = $6 + $8
-
- if (machi[mach] == 0) {
- machn[nmach] = mach;
- machi[mach] = 1;
- ++nmach;
- }
-
- us_per_op = time / iter * 1000000
- times[mach "_" test] = us_per_op;
-}
-
-
-END {
- for (i=0; i<nmach; ++i) {
- m = machn[i];
-
- integer = times[m "_" test_int];
- fp = times[m "_" test_fp];
- printf ("%s|%3.1f|%3.1f\n", m, integer, fp);
- }
-}
+++ /dev/null
-#! /bin/awk -f
-
-BEGIN {
- purpose = "report times used for init/start/stop";
-
- nmach = 0;
-
- test_single = "6";
- test_v0 = "10";
- test_v2 = "11";
- test_v4 = "12";
- test_v8 = "13";
-}
-
-{
- mach = $1
- test = $2
- iter = $3
- time = $6 + $8
-
- if (machi[mach] == 0) {
- machn[nmach] = mach;
- machi[mach] = 1;
- ++nmach;
- }
-
- us_per_op = time / iter * 1000000
- times[mach "_" test] = us_per_op;
-}
-
-
-END {
- for (i=0; i<nmach; ++i) {
- m = machn[i];
-
- single = times[m "_" test_single];
- v0 = times[m "_" test_v0];
- v2 = times[m "_" test_v2];
- v4 = times[m "_" test_v4];
- v8 = times[m "_" test_v8];
- printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8);
- }
-}
+++ /dev/null
-#! /bin/awk -f
-
-BEGIN {
- purpose = "Report time used to initialize a thread."
- nmach = 0;
-
- test_single = "1";
- test_v0 = "14";
- test_v2 = "15";
- test_v4 = "16";
- test_v8 = "17";
-}
-
-{
- mach = $1
- test = $2
- iter = $3
- time = $6 + $8
-
- if (machi[mach] == 0) {
- machn[nmach] = mach;
- machi[mach] = 1;
- ++nmach;
- }
-
- us_per_op = time / iter * 1000000
- times[mach "_" test] = us_per_op;
-}
-
-
-END {
- for (i=0; i<nmach; ++i) {
- m = machn[i];
-
- single = times[m "_" test_single];
- v0 = times[m "_" test_v0];
- v2 = times[m "_" test_v2];
- v4 = times[m "_" test_v4];
- v8 = times[m "_" test_v8];
- printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8);
- }
-}
+++ /dev/null
-#! /bin/awk -f
-
-BEGIN {
- purpose = "report times for microbenchmarks"
-
- nmach = 0;
-
- test_callind = "18";
- test_callimm = "18";
- test_addreg = "20";
- test_loadreg = "21";
-}
-
-{
- mach = $1
- test = $2
- iter = $3
- time = $6 + $8
-
- if (machi[mach] == 0) {
- machn[nmach] = mach;
- machi[mach] = 1;
- ++nmach;
- }
-
- ns_per_op = time / iter * 1000000
- times[mach "_" test] = ns_per_op;
-}
-
-
-END {
- for (i=0; i<nmach; ++i) {
- m = machn[i];
-
- ind = times[m "_" test_callind];
- imm = times[m "_" test_callimm];
- add = times[m "_" test_addreg];
- load = times[m "_" test_loadreg];
- printf ("%s|%1.3f|%1.3f|%1.3f|%1.3f\n", m, ind, imm, add, load);
- }
-}
+++ /dev/null
-#! /bin/csh
-
-rm -f timed
-
-set init=1
-set runone=6
-set blockint=7
-set blockfloat=8
-set vainit0=14
-set vainit2=15
-set vainit4=16
-set vainit8=17
-set vastart0=10
-set vastart2=11
-set vastart4=12
-set vastart8=13
-set bench_regcall=18
-set bench_immcall=19
-set bench_add=20
-set bench_load=21
-
-source configuration
-
-echo -n $config_machine $init $config_init
-/bin/time run $init $config_init
-echo -n $config_machine $runone $config_runone
-/bin/time run $runone $config_runone
-echo -n $config_machine $blockint $config_blockint
-/bin/time run $blockint $config_blockint
-echo -n $config_machine $blockfloat $config_blockfloat
-/bin/time run $blockfloat $config_blockfloat
-
-echo -n $config_machine $vainit0 $config_vainit0
-/bin/time run $vainit0 $config_vainit0
-echo -n $config_machine $vainit2 $config_vainit2
-/bin/time run $vainit2 $config_vainit2
-echo -n $config_machine $vainit4 $config_vainit4
-/bin/time run $vainit4 $config_vainit4
-echo -n $config_machine $vainit8 $config_vainit8
-/bin/time run $vainit8 $config_vainit8
-
-echo -n $config_machine $vastart0 $config_vastart0
-/bin/time run $vastart0 $config_vastart0
-echo -n $config_machine $vastart2 $config_vastart2
-/bin/time run $vastart2 $config_vastart2
-echo -n $config_machine $vastart4 $config_vastart4
-/bin/time run $vastart4 $config_vastart4
-echo -n $config_machine $vastart8 $config_vastart8
-/bin/time run $vastart8 $config_vastart8
-
-echo -n $config_machine $bench_regcall $config_bcall_reg
-/bin/time run $bench_regcall $config_bcall_reg
-echo -n $config_machine $bench_immcall $config_bcall_imm
-/bin/time run $bench_immcall $config_bcall_imm
-echo -n $config_machine $bench_add $config_b_add
-/bin/time run $bench_add $config_b_add
-echo -n $config_machine $bench_load $config_b_load
-/bin/time run $bench_load $config_b_load
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+## Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
-I$(top_srcdir)/lib -I$(top_builddir)/lib
AM_CFLAGS = $(GCC_CFLAGS)
+AM_LDFLAGS = $(GNU_LD_FLAGS)
srfiincludedir = $(pkgincludedir)/srfi
/* srfi-1.c --- SRFI-1 procedures for Guile
*
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008
+ * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008, 2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
"make a new define under a different name.")
#define FUNC_NAME s_scm_srfi1_break
{
- scm_t_trampoline_1 pred_tramp;
SCM ret, *p;
- pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
ret = SCM_EOL;
p = &ret;
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
SCM elem = SCM_CAR (lst);
- if (scm_is_true (pred_tramp (pred, elem)))
+ if (scm_is_true (scm_call_1 (pred, elem)))
goto done;
/* want this elem, tack it onto the end of ret */
#define FUNC_NAME s_scm_srfi1_break_x
{
SCM upto, *p;
- scm_t_trampoline_1 pred_tramp;
- pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
p = &lst;
for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
{
- if (scm_is_true (pred_tramp (pred, SCM_CAR (upto))))
+ if (scm_is_true (scm_call_1 (pred, SCM_CAR (upto))))
goto done;
/* want this element */
if (scm_is_null (rest))
{
/* one list */
- scm_t_trampoline_1 pred_tramp;
- pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
- count += scm_is_true (pred_tramp (pred, SCM_CAR (list1)));
+ count += scm_is_true (scm_call_1 (pred, SCM_CAR (list1)));
/* check below that list1 is a proper list, and done */
end_list1:
else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
{
/* two lists */
- scm_t_trampoline_2 pred_tramp;
SCM list2;
- pred_tramp = scm_trampoline_2 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
list2 = SCM_CAR (rest);
for (;;)
argnum = 3;
break;
}
- count += scm_is_true (pred_tramp
+ count += scm_is_true (scm_call_2
(pred, SCM_CAR (list1), SCM_CAR (list2)));
list1 = SCM_CDR (list1);
list2 = SCM_CDR (list2);
"common tail with @var{lst}.")
#define FUNC_NAME s_scm_srfi1_delete
{
- scm_t_trampoline_2 equal_p;
SCM ret, *p, keeplst;
int count;
if (SCM_UNBNDP (pred))
return scm_delete (x, lst);
- equal_p = scm_trampoline_2 (pred);
- SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
/* ret is the return list being constructed. p is where to append to it,
initially &ret then SCM_CDRLOC of the last pair. lst progresses as
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
- if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
+ if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (lst))))
{
/* delete this element, so copy those at keeplst */
p = list_copy_part (keeplst, count, p);
"@var{lst} may be modified to construct the returned list.")
#define FUNC_NAME s_scm_srfi1_delete_x
{
- scm_t_trampoline_2 equal_p;
SCM walk;
SCM *prev;
if (SCM_UNBNDP (pred))
return scm_delete_x (x, lst);
- equal_p = scm_trampoline_2 (pred);
- SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
for (prev = &lst, walk = lst;
scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (scm_is_true (equal_p (pred, x, SCM_CAR (walk))))
+ if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (walk))))
*prev = SCM_CDR (walk);
else
prev = SCM_CDRLOC (walk);
equal_p = equal_trampoline;
else
{
- equal_p = scm_trampoline_2 (pred);
- SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG2, pred);
+ equal_p = scm_call_2;
}
keeplst = lst;
equal_p = equal_trampoline;
else
{
- equal_p = scm_trampoline_2 (pred);
- SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG2, pred);
+ equal_p = scm_call_2;
}
endret = ret;
"satisfy the predicate @var{pred}.")
#define FUNC_NAME s_scm_srfi1_drop_while
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- if (scm_is_false (pred_tramp (pred, SCM_CAR (lst))))
+ if (scm_is_false (scm_call_1 (pred, SCM_CAR (lst))))
goto done;
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
if (scm_is_null (rest))
{
/* one list */
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
{
- elem = proc_tramp (proc, SCM_CAR (list1));
+ elem = scm_call_1 (proc, SCM_CAR (list1));
if (scm_is_true (elem))
{
newcell = scm_cons (elem, SCM_EOL);
else if (scm_is_null (SCM_CDR (rest)))
{
/* two lists */
- scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
SCM list2 = SCM_CAR (rest);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
for (;;)
{
argnum = 3;
goto check_lst_and_done;
}
- elem = proc_tramp (proc, SCM_CAR (list1), SCM_CAR (list2));
+ elem = scm_call_2 (proc, SCM_CAR (list1), SCM_CAR (list2));
if (scm_is_true (elem))
{
newcell = scm_cons (elem, SCM_EOL);
"found.")
#define FUNC_NAME s_scm_srfi1_find
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
SCM elem = SCM_CAR (lst);
- if (scm_is_true (pred_tramp (pred, elem)))
+ if (scm_is_true (scm_call_1 (pred, elem)))
return elem;
}
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
"found.")
#define FUNC_NAME s_scm_srfi1_find_tail
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- if (scm_is_true (pred_tramp (pred, SCM_CAR (lst))))
+ if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
return lst;
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
if (scm_is_null (rest))
{
/* one list */
- scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
- init = proc_tramp (proc, SCM_CAR (list1), init);
+ init = scm_call_2 (proc, SCM_CAR (list1), init);
/* check below that list1 is a proper list, and done */
lst = list1;
if (scm_is_null (rest))
{
/* one list */
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
- if (scm_is_true (pred_tramp (pred, SCM_CAR (list1))))
+ if (scm_is_true (scm_call_1 (pred, SCM_CAR (list1))))
return SCM_I_MAKINUM (n);
/* not found, check below that list1 is a proper list */
{
/* two lists */
SCM list2 = SCM_CAR (rest);
- scm_t_trampoline_2 pred_tramp = scm_trampoline_2 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
for ( ; ; n++)
{
argnum = 3;
break;
}
- if (scm_is_true (pred_tramp (pred,
+ if (scm_is_true (scm_call_2 (pred,
SCM_CAR (list1), SCM_CAR (list2))))
return SCM_I_MAKINUM (n);
#define FUNC_NAME s_scm_srfi1_list_tabulate
{
long i, nn;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
SCM ret = SCM_EOL;
-
nn = scm_to_signed_integer (n, 0, LONG_MAX);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG2, FUNC_NAME);
-
+ SCM_VALIDATE_PROC (SCM_ARG2, proc);
for (i = nn-1; i >= 0; i--)
- ret = scm_cons (proc_tramp (proc, scm_from_long (i)), ret);
-
+ ret = scm_cons (scm_call_1 (proc, scm_from_long (i)), ret);
return ret;
}
#undef FUNC_NAME
"@end example")
#define FUNC_NAME s_scm_srfi1_lset_adjoin
{
- scm_t_trampoline_2 equal_tramp;
SCM l, elem;
- equal_tramp = scm_trampoline_2 (equal);
- SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, equal);
SCM_VALIDATE_REST_ARGUMENT (rest);
/* It's not clear if duplicates among the `rest' elements are meant to be
elem = SCM_CAR (rest);
for (l = lst; scm_is_pair (l); l = SCM_CDR (l))
- if (scm_is_true (equal_tramp (equal, SCM_CAR (l), elem)))
+ if (scm_is_true (scm_call_2 (equal, SCM_CAR (l), elem)))
goto next_elem; /* elem already in lst, don't add */
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l), lst, SCM_ARG2, FUNC_NAME, "list");
"result.")
#define FUNC_NAME s_scm_srfi1_lset_difference_x
{
- scm_t_trampoline_2 equal_tramp = scm_trampoline_2 (equal);
SCM ret, *pos, elem, r, b;
int argnum;
- SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, equal);
SCM_VALIDATE_REST_ARGUMENT (rest);
ret = SCM_EOL;
r = SCM_CDR (r), argnum++)
{
for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
- if (scm_is_true (equal_tramp (equal, elem, SCM_CAR (b))))
+ if (scm_is_true (scm_call_2 (equal, elem, SCM_CAR (b))))
goto next_elem; /* equal to elem, so drop that elem */
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
SCM_VALIDATE_REST_ARGUMENT (args);
if (scm_is_null (args))
{
- scm_t_trampoline_1 call = scm_trampoline_1 (proc);
- SCM_GASSERT2 (call, g_srfi1_map, proc, arg1, SCM_ARG1, s_srfi1_map);
+ SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_srfi1_map,
+ proc, arg1, SCM_ARG1, s_srfi1_map);
SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map);
while (SCM_NIMP (arg1))
{
- *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
+ *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1)));
pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1);
}
{
SCM arg2 = SCM_CAR (args);
int len2 = srfi1_ilength (arg2);
- scm_t_trampoline_2 call = scm_trampoline_2 (proc);
- SCM_GASSERTn (call, g_srfi1_map,
+ SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_srfi1_map,
scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map);
if (len < 0 || (len2 >= 0 && len2 < len))
len = len2;
s_srfi1_map);
while (len > 0)
{
- *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
+ *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1);
arg2 = SCM_CDR (arg2);
SCM_VALIDATE_REST_ARGUMENT (args);
if (scm_is_null (args))
{
- scm_t_trampoline_1 call = scm_trampoline_1 (proc);
- SCM_GASSERT2 (call, g_srfi1_for_each, proc, arg1,
- SCM_ARG1, s_srfi1_for_each);
+ SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_srfi1_for_each,
+ proc, arg1, SCM_ARG1, s_srfi1_for_each);
SCM_GASSERT2 (len >= 0, g_srfi1_for_each, proc, arg1,
SCM_ARG2, s_srfi1_map);
while (SCM_NIMP (arg1))
{
- call (proc, SCM_CAR (arg1));
+ scm_call_1 (proc, SCM_CAR (arg1));
arg1 = SCM_CDR (arg1);
}
return SCM_UNSPECIFIED;
{
SCM arg2 = SCM_CAR (args);
int len2 = srfi1_ilength (arg2);
- scm_t_trampoline_2 call = scm_trampoline_2 (proc);
- SCM_GASSERTn (call, g_srfi1_for_each,
+ SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_srfi1_for_each,
scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each);
if (len < 0 || (len2 >= 0 && len2 < len))
len = len2;
s_srfi1_for_each);
while (len > 0)
{
- call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
+ scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2));
arg1 = SCM_CDR (arg1);
arg2 = SCM_CDR (arg2);
--len;
equal_p = equal_trampoline;
else
{
- equal_p = scm_trampoline_2 (pred);
- SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG3, pred);
+ equal_p = scm_call_2;
}
for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
{
equal_p = equal_trampoline;
else
{
- equal_p = scm_trampoline_2 (pred);
- SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG3, pred);
+ equal_p = scm_call_2;
}
for(; scm_is_pair (ls); ls = SCM_CDR (ls))
{
{
/* In this implementation, the output lists don't share memory with
list, because it's probably not worth the effort. */
- scm_t_trampoline_1 call = scm_trampoline_1(pred);
SCM orig_list = list;
SCM kept = scm_cons(SCM_EOL, SCM_EOL);
SCM kept_tail = kept;
SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
SCM dropped_tail = dropped;
- SCM_ASSERT(call, pred, 2, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
SCM elt, new_tail;
elt = SCM_CAR (list);
new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
- if (scm_is_true (call (pred, elt))) {
+ if (scm_is_true (scm_call_1 (pred, elt))) {
SCM_SETCDR(kept_tail, new_tail);
kept_tail = new_tail;
}
#define FUNC_NAME s_scm_srfi1_partition_x
{
SCM tlst, flst, *tp, *fp;
- scm_t_trampoline_1 pred_tramp;
- pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
/* tlst and flst are the lists of true and false elements. tp and fp are
where to store to append to them, initially &tlst and &flst, then
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
- if (scm_is_true (pred_tramp (pred, SCM_CAR (lst))))
+ if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
{
*tp = lst;
tp = SCM_CDRLOC (lst);
"avoids that unnecessary call.")
#define FUNC_NAME s_scm_srfi1_reduce
{
- scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
- SCM ret;
-
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
-
+ SCM ret;
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
ret = def; /* if lst is empty */
if (scm_is_pair (lst))
{
ret = SCM_CAR (lst); /* if lst has one element */
for (lst = SCM_CDR (lst); scm_is_pair (lst); lst = SCM_CDR (lst))
- ret = proc_tramp (proc, SCM_CAR (lst), ret);
+ ret = scm_call_2 (proc, SCM_CAR (lst), ret);
}
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG3, FUNC_NAME, "list");
is long. A vector is preferred over a reversed list since it's more
compact and is less work for the gc to collect. */
- scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
- SCM ret, vec;
- long len, i;
-
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
-
+ SCM vec, ret;
+ ssize_t len, i;
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
if (SCM_NULL_OR_NIL_P (lst))
return def;
ret = SCM_SIMPLE_VECTOR_REF (vec, len-1);
for (i = len-2; i >= 0; i--)
- ret = proc_tramp (proc, SCM_SIMPLE_VECTOR_REF (vec, i), ret);
+ ret = scm_call_2 (proc, SCM_SIMPLE_VECTOR_REF (vec, i), ret);
return ret;
}
"specified.")
#define FUNC_NAME s_scm_srfi1_remove
{
- scm_t_trampoline_1 call = scm_trampoline_1 (pred);
SCM walk;
SCM *prev;
SCM res = SCM_EOL;
- SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
SCM_VALIDATE_LIST (2, list);
for (prev = &res, walk = list;
scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (scm_is_false (call (pred, SCM_CAR (walk))))
+ if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
{
*prev = scm_cons (SCM_CAR (walk), SCM_EOL);
prev = SCM_CDRLOC (*prev);
"list.")
#define FUNC_NAME s_scm_srfi1_remove_x
{
- scm_t_trampoline_1 call = scm_trampoline_1 (pred);
SCM walk;
SCM *prev;
- SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
SCM_VALIDATE_LIST (2, list);
for (prev = &list, walk = list;
scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (scm_is_false (call (pred, SCM_CAR (walk))))
+ if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
prev = SCM_CDRLOC (walk);
else
*prev = SCM_CDR (walk);
"remainder of @var{lst}.")
#define FUNC_NAME s_scm_srfi1_span
{
- scm_t_trampoline_1 pred_tramp;
SCM ret, *p;
- pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
ret = SCM_EOL;
p = &ret;
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
SCM elem = SCM_CAR (lst);
- if (scm_is_false (pred_tramp (pred, elem)))
+ if (scm_is_false (scm_call_1 (pred, elem)))
goto done;
/* want this elem, tack it onto the end of ret */
#define FUNC_NAME s_scm_srfi1_span_x
{
SCM upto, *p;
- scm_t_trampoline_1 pred_tramp;
- pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
p = &lst;
for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
{
- if (scm_is_false (pred_tramp (pred, SCM_CAR (upto))))
+ if (scm_is_false (scm_call_1 (pred, SCM_CAR (upto))))
goto done;
/* want this element */
"@var{lst} whose elements all satisfy the predicate @var{pred}.")
#define FUNC_NAME s_scm_srfi1_take_while
{
- scm_t_trampoline_1 pred_tramp;
SCM ret, *p;
- pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
ret = SCM_EOL;
p = &ret;
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
SCM elem = SCM_CAR (lst);
- if (scm_is_false (pred_tramp (pred, elem)))
+ if (scm_is_false (scm_call_1 (pred, elem)))
goto done;
/* want this elem, tack it onto the end of ret */
#define FUNC_NAME s_scm_srfi1_take_while_x
{
SCM upto, *p;
- scm_t_trampoline_1 pred_tramp;
- pred_tramp = scm_trampoline_1 (pred);
- SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
p = &lst;
for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
{
- if (scm_is_false (pred_tramp (pred, SCM_CAR (upto))))
+ if (scm_is_false (scm_call_1 (pred, SCM_CAR (upto))))
goto done;
/* want this element */
tests/arbiters.test \
tests/asm-to-bytecode.test \
tests/bit-operations.test \
+ tests/brainfuck.test \
tests/bytevectors.test \
tests/c-api.test \
tests/chars.test \
tests/elisp.test \
tests/elisp-compiler.text \
tests/elisp-reader.text \
- tests/environments.test \
tests/eval.test \
tests/exceptions.test \
tests/filesys.test \
tests/i18n.test \
tests/import.test \
tests/interp.test \
+ tests/keywords.test \
tests/list.test \
tests/load.test \
tests/modules.test \
tests/reader.test \
tests/receive.test \
tests/regexp.test \
+ tests/signals.test \
tests/socket.test \
tests/srcprop.test \
tests/srfi-1.test \
;; Using the debugging evaluator.
with-debugging-evaluator with-debugging-evaluator*
+;; Using a given locale
+with-locale with-locale*
+
;; Reporting results in various ways.
register-reporter unregister-reporter reporter-registered?
make-count-reporter print-counts
(define-macro (with-debugging-evaluator . body)
`(with-debugging-evaluator* (lambda () ,@body)))
+;;; Call THUNK with a given locale
+(define (with-locale* nloc thunk)
+ (let ((loc #f))
+ (dynamic-wind
+ (lambda ()
+ (if (defined? 'setlocale)
+ (begin
+ (set! loc
+ (false-if-exception (setlocale LC_ALL nloc)))
+ (if (not loc)
+ (throw 'unresolved)))
+ (throw 'unresolved)))
+ thunk
+ (lambda ()
+ (if (defined? 'setlocale)
+ (setlocale LC_ALL loc))))))
+
+;;; Evaluate BODY... using the given locale.
+(define-macro (with-locale loc . body)
+ `(with-locale* ,loc (lambda () ,@body)))
\f
;;;; REPORTERS
/test-scm-c-read
/test-fast-slot-ref
/test-scm-take-locale-symbol
+/test-scm-take-u8vector
+/test-loose-ends
check_PROGRAMS += test-conversion
TESTS += test-conversion
+# test-loose-ends
+test_loose_ends_SOURCES = test-loose-ends.c
+test_loose_ends_CFLAGS = ${test_cflags}
+test_loose_ends_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-loose-ends
+TESTS += test-loose-ends
+
# test-fast-slot-ref
check_SCRIPTS += test-fast-slot-ref
TESTS += test-fast-slot-ref
check_PROGRAMS += test-scm-take-locale-symbol
TESTS += test-scm-take-locale-symbol
+# test-scm-take-u8vector
+test_scm_take_u8vector_SOURCES = test-scm-take-u8vector.c
+test_scm_take_u8vector_CFLAGS = ${test_cflags}
+test_scm_take_u8vector_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-scm-take-u8vector
+TESTS += test-scm-take-u8vector
+
# test-extensions
noinst_LTLIBRARIES += libtest-extensions.la
libtest_extensions_la_SOURCES = test-extensions-lib.c
before trying to use it. (But in practice we believe this is not a
problem on any system guile is likely to target.) */
guile_Inf = INFINITY;
-#elif HAVE_DINFINITY
+#elif defined HAVE_DINFINITY
/* OSF */
extern unsigned int DINFINITY[2];
guile_Inf = (*((double *) (DINFINITY)));
#ifdef NAN
/* C99 NAN, when available */
guile_NaN = NAN;
-#elif HAVE_DQNAN
+#elif defined HAVE_DQNAN
{
/* OSF */
extern unsigned int DQNAN[2];
--- /dev/null
+/* test-loose-ends.c
+ *
+ * Test items of the Guile C API that aren't covered by any other tests.
+ */
+
+/* Copyright (C) 2009 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
+ */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdio.h>
+#include <assert.h>
+#include <string.h>
+
+#ifdef HAVE_INTTYPES_H
+# include <inttypes.h>
+#endif
+
+static void
+test_scm_from_locale_keywordn ()
+{
+ SCM kw = scm_from_locale_keywordn ("thusly", 4);
+ assert (scm_is_true (scm_keyword_p (kw)));
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ test_scm_from_locale_keywordn ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
--- /dev/null
+/* Copyright (C) 2009 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
+ */
+
+/* Make sure `scm_take_u8vector ()' returns a u8vector that actually uses the
+ provided storage. */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdlib.h>
+
+\f
+static void *
+do_test (void *result)
+{
+#define LEN 123
+ SCM u8v;
+ scm_t_uint8 *data;
+ scm_t_array_handle handle;
+
+ data = scm_malloc (LEN);
+ u8v = scm_take_u8vector (data, LEN);
+
+ scm_array_get_handle (u8v, &handle);
+
+ if (scm_array_handle_u8_writable_elements (&handle) == data
+ && scm_array_handle_u8_elements (&handle) == data)
+ * (int *) result = EXIT_SUCCESS;
+ else
+ * (int *) result = EXIT_FAILURE;
+
+ scm_array_handle_release (&handle);
+
+ return NULL;
+#undef LEN
+}
+
+int
+main (int argc, char *argv[])
+{
+ int result;
+
+ scm_with_guile (do_test, &result);
+
+ return result;
+}
-/* Copyright (C) 2004, 2005, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2004, 2005, 2008, 2009 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
if (tmpdir == NULL)
tmpdir = "/tmp";
- filename = (char *) alloca (strlen (tmpdir) +
- sizeof (FILENAME_TEMPLATE) + 1);
+ filename = alloca (strlen (tmpdir) + sizeof (FILENAME_TEMPLATE) + 1);
strcpy (filename, tmpdir);
strcat (filename, FILENAME_TEMPLATE);
(vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
(char->integer #\o)))
- (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
+ (comp-test '(load-program () 3 #f (make-int8 3) (return))
#(load-program
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 3) ;; len
(uint32 0) ;; metalen
- (uint32 0) ;; padding
make-int8 3
return))
;; the nops are to pad meta to an 8-byte alignment. not strictly
;; necessary for this test, but representative of the common case.
- (comp-test '(load-program 3 2 1 () 8
- (load-program 3 2 1 () 3
+ (comp-test '(load-program () 8
+ (load-program () 3
#f
(make-int8 3) (return))
(make-int8 3) (return)
(nop) (nop) (nop) (nop) (nop))
#(load-program
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 8) ;; len
- (uint32 19) ;; metalen
- (uint32 0) ;; padding
+ (uint32 11) ;; metalen
make-int8 3
return
nop nop nop nop nop
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 3) ;; len
(uint32 0) ;; metalen
- (uint32 0) ;; padding
make-int8 3
return))))
--- /dev/null
+;;;; test brainfuck compilation -*- scheme -*-
+;;;;
+;;;; 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
+
+(define-module (test-suite tests brainfuck)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile))
+
+;; This program taken from Wikipedia's brainfuck introduction page.
+(define prog "
+ +++ +++ +++ + initialize counter (cell #0) to 10
+ [ use loop to set the next four cells to 70/100/30/10
+ > +++ +++ + add 7 to cell #1
+ > +++ +++ +++ + add 10 to cell #2
+ > +++ add 3 to cell #3
+ > + add 1 to cell #4
+ <<< < - decrement counter (cell #0)
+ ]
+ >++ . print 'H'
+ >+. print 'e'
+ +++ +++ +. print 'l'
+ . print 'l'
+ +++ . print 'o'
+ >++ . print ' '
+ <<+ +++ +++ +++ +++ ++. print 'W'
+ >. print 'o'
+ +++ . print 'r'
+ --- --- . print 'l'
+ --- --- --. print 'd'
+ >+. print '!'")
+
+(pass-if
+ (equal? (with-output-to-string
+ (lambda ()
+ (call-with-input-string
+ prog
+ (lambda (port)
+ (read-and-compile port #:from 'brainfuck #:to 'value)))))
+ "Hello World!"))
(begin (pass-if (string-append test-name " (eval)")
(primitive-eval 'exp))
(pass-if (string-append test-name " (compile)")
- (compile 'exp #:to 'value))))
+ (compile 'exp #:to 'value #:env (current-module)))))
((_ (pass-if-exception test-name exc exp))
(begin (pass-if-exception (string-append test-name " (eval)")
exc (primitive-eval 'exp))
(pass-if-exception (string-append test-name " (compile)")
- exc (compile 'exp #:to 'value))))))
+ exc (compile 'exp #:to 'value
+ #:env (current-module)))))))
(define-syntax with-test-prefix/c&e
(syntax-rules ()
(equal? (with-input-from-string "#vu8(0 255 127 128)" read)
(u8-list->bytevector '(0 255 127 128))))
+ (pass-if "self-evaluating?"
+ (self-evaluating? (make-bytevector 1)))
+
(pass-if "self-evaluating"
(equal? (eval (with-input-from-string "#vu8(1 2 3 4 5)" read)
(current-module))
(pass-if-exception "make-typed-array [out-of-range]"
exception:out-of-range
- (make-typed-array 'vu8 256 77))
+ (make-typed-array 'vu8 256 77)))
+
+\f
+(with-test-prefix "uniform-array->bytevector"
- (pass-if "uniform-array->bytevector"
+ (pass-if "bytevector"
(let ((bv #vu8(0 1 128 255)))
- (equal? bv (uniform-array->bytevector bv)))))
+ (equal? bv (uniform-array->bytevector bv))))
+
+ (pass-if "empty bitvector"
+ (let ((bv (uniform-array->bytevector (make-bitvector 0))))
+ (equal? bv #vu8())))
+
+ (pass-if "bitvector < 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
+ (= (bytevector-length bv) 1)))
+
+ (pass-if "bitvector == 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
+ (= (bytevector-length bv) 1)))
+
+ (pass-if "bitvector > 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
+ (= (bytevector-length bv) 2))))
;;; Local Variables:
;;;; chars.test --- test suite for Guile's char functions -*- scheme -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
-;;;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2006, 2009 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
(define exception:wrong-type-to-apply
(cons 'misc-error "^Wrong type to apply:"))
+(define exception:unknown-character-name
+ (cons #t "unknown character"))
+
+(define exception:out-of-range-octal
+ (cons #t "out-of-range"))
+
(with-test-prefix "basic char handling"
;; The following test makes sure that the evaluator distinguishes between
;; evaluator-internal instruction codes and characters.
(pass-if-exception "evaluating chars"
- exception:wrong-type-to-apply
- (eval '(#\0) (interaction-environment)))))
-
-(pass-if "char-is-both? works"
- (and
- (not (char-is-both? #\?))
- (not (char-is-both? #\newline))
- (char-is-both? #\a)
- (char-is-both? #\Z)
- (not (char-is-both? #\1))))
+ exception:wrong-type-arg
+ (eval '(#\0) (interaction-environment))))
+
+ (with-test-prefix "comparisons"
+
+ ;; char=?
+ (pass-if "char=? #\\A #\\A"
+ (char=? #\A #\A))
+
+ (expect-fail "char=? #\\A #\\a"
+ (char=? #\A #\a))
+
+ (expect-fail "char=? #\\A #\\B"
+ (char=? #\A #\B))
+
+ (expect-fail "char=? #\\B #\\A"
+ (char=? #\A #\B))
+
+ ;; char<?
+ (expect-fail "char<? #\\A #\\A"
+ (char<? #\A #\A))
+
+ (pass-if "char<? #\\A #\\a"
+ (char<? #\A #\a))
+
+ (pass-if "char<? #\\A #\\B"
+ (char<? #\A #\B))
+
+ (expect-fail "char<? #\\B #\\A"
+ (char<? #\B #\A))
+
+ ;; char<=?
+ (pass-if "char<=? #\\A #\\A"
+ (char<=? #\A #\A))
+
+ (pass-if "char<=? #\\A #\\a"
+ (char<=? #\A #\a))
+
+ (pass-if "char<=? #\\A #\\B"
+ (char<=? #\A #\B))
+
+ (expect-fail "char<=? #\\B #\\A"
+ (char<=? #\B #\A))
+
+ ;; char>?
+ (expect-fail "char>? #\\A #\\A"
+ (char>? #\A #\A))
+
+ (expect-fail "char>? #\\A #\\a"
+ (char>? #\A #\a))
+
+ (expect-fail "char>? #\\A #\\B"
+ (char>? #\A #\B))
+
+ (pass-if "char>? #\\B #\\A"
+ (char>? #\B #\A))
+
+ ;; char>=?
+ (pass-if "char>=? #\\A #\\A"
+ (char>=? #\A #\A))
+
+ (expect-fail "char>=? #\\A #\\a"
+ (char>=? #\A #\a))
+
+ (expect-fail "char>=? #\\A #\\B"
+ (char>=? #\A #\B))
+
+ (pass-if "char>=? #\\B #\\A"
+ (char>=? #\B #\A))
+
+ ;; char-ci=?
+ (pass-if "char-ci=? #\\A #\\A"
+ (char-ci=? #\A #\A))
+
+ (pass-if "char-ci=? #\\A #\\a"
+ (char-ci=? #\A #\a))
+
+ (expect-fail "char-ci=? #\\A #\\B"
+ (char-ci=? #\A #\B))
+
+ (expect-fail "char-ci=? #\\B #\\A"
+ (char-ci=? #\A #\B))
+
+ ;; char-ci<?
+ (expect-fail "char-ci<? #\\A #\\A"
+ (char-ci<? #\A #\A))
+
+ (expect-fail "char-ci<? #\\A #\\a"
+ (char-ci<? #\A #\a))
+
+ (pass-if "char-ci<? #\\A #\\B"
+ (char-ci<? #\A #\B))
+
+ (expect-fail "char-ci<? #\\B #\\A"
+ (char-ci<? #\B #\A))
+
+ ;; char-ci<=?
+ (pass-if "char-ci<=? #\\A #\\A"
+ (char-ci<=? #\A #\A))
+
+ (pass-if "char-ci<=? #\\A #\\a"
+ (char-ci<=? #\A #\a))
+
+ (pass-if "char-ci<=? #\\A #\\B"
+ (char-ci<=? #\A #\B))
+
+ (expect-fail "char-ci<=? #\\B #\\A"
+ (char-ci<=? #\B #\A))
+
+ ;; char-ci>?
+ (expect-fail "char-ci>? #\\A #\\A"
+ (char-ci>? #\A #\A))
+
+ (expect-fail "char-ci>? #\\A #\\a"
+ (char-ci>? #\A #\a))
+
+ (expect-fail "char-ci>? #\\A #\\B"
+ (char-ci>? #\A #\B))
+
+ (pass-if "char-ci>? #\\B #\\A"
+ (char-ci>? #\B #\A))
+
+ ;; char-ci>=?
+ (pass-if "char-ci>=? #\\A #\\A"
+ (char-ci>=? #\A #\A))
+
+ (pass-if "char-ci>=? #\\A #\\a"
+ (char-ci>=? #\A #\a))
+
+ (expect-fail "char-ci>=? #\\A #\\B"
+ (char-ci>=? #\A #\B))
+
+ (pass-if "char-ci>=? #\\B #\\A"
+ (char-ci>=? #\B #\A)))
+
+ (with-test-prefix "categories"
+
+ (pass-if "char-alphabetic?"
+ (and (char-alphabetic? #\a)
+ (char-alphabetic? #\A)
+ (not (char-alphabetic? #\1))
+ (not (char-alphabetic? #\+))))
+
+ (pass-if "char-numeric?"
+ (and (not (char-numeric? #\a))
+ (not (char-numeric? #\A))
+ (char-numeric? #\1)
+ (not (char-numeric? #\+))))
+
+ (pass-if "char-whitespace?"
+ (and (not (char-whitespace? #\a))
+ (not (char-whitespace? #\A))
+ (not (char-whitespace? #\1))
+ (char-whitespace? #\space)
+ (not (char-whitespace? #\+))))
+
+ (pass-if "char-upper-case?"
+ (and (not (char-upper-case? #\a))
+ (char-upper-case? #\A)
+ (not (char-upper-case? #\1))
+ (not (char-upper-case? #\+))))
+
+ (pass-if "char-lower-case?"
+ (and (char-lower-case? #\a)
+ (not (char-lower-case? #\A))
+ (not (char-lower-case? #\1))
+ (not (char-lower-case? #\+))))
+
+ (pass-if "char-is-both? works"
+ (and
+ (not (char-is-both? #\?))
+ (not (char-is-both? #\newline))
+ (char-is-both? #\a)
+ (char-is-both? #\Z)
+ (not (char-is-both? #\1)))))
+
+ (with-test-prefix "integer"
+
+ (pass-if "char->integer"
+ (eqv? (char->integer #\A) 65))
+
+ (pass-if "integer->char"
+ (eqv? (integer->char 65) #\A))
+
+ (pass-if-exception "integer->char out of range, -1" exception:out-of-range
+ (integer->char -1))
+
+ (pass-if-exception "integer->char out of range, surrrogate"
+ exception:out-of-range
+ (integer->char #xd800))
+
+ (pass-if-exception "integer->char out of range, too big"
+ exception:out-of-range
+ (integer->char #x110000))
+
+ (pass-if-exception "octal out of range, surrrogate"
+ exception:out-of-range-octal
+ (with-input-from-string "#\\154000" read))
+
+ (pass-if-exception "octal out of range, too big"
+ exception:out-of-range-octal
+ (with-input-from-string "#\\4200000" read)))
+
+ (with-test-prefix "case"
+
+ (pass-if "char-upcase"
+ (eqv? (char-upcase #\a) #\A))
+
+ (pass-if "char-downcase"
+ (eqv? (char-downcase #\A) #\a)))
+
+ (with-test-prefix "charnames"
+
+ (pass-if "R5RS character names are case insensitive"
+ (and (eqv? #\space #\ )
+ (eqv? #\SPACE #\ )
+ (eqv? #\Space #\ )
+ (eqv? #\newline (integer->char 10))
+ (eqv? #\NEWLINE (integer->char 10))
+ (eqv? #\Newline (integer->char 10))))
+
+ (pass-if "C0 control names are case insensitive"
+ (and (eqv? #\nul #\000)
+ (eqv? #\soh #\001)
+ (eqv? #\stx #\002)
+ (eqv? #\NUL #\000)
+ (eqv? #\SOH #\001)
+ (eqv? #\STX #\002)
+ (eqv? #\Nul #\000)
+ (eqv? #\Soh #\001)
+ (eqv? #\Stx #\002)))
+
+ (pass-if "alt charnames are case insensitive"
+ (eqv? #\null #\nul)
+ (eqv? #\NULL #\nul)
+ (eqv? #\Null #\nul))
+
+ (pass-if-exception "bad charname" exception:unknown-character-name
+ (with-input-from-string "#\\blammo" read))
+
+ (pass-if "R5RS character names are preferred write format"
+ (string=?
+ (with-output-to-string (lambda () (write #\space)))
+ "#\\space"))
+
+ (pass-if "C0 control character names are preferred write format"
+ (string=?
+ (with-output-to-string (lambda () (write #\soh)))
+ "#\\soh"))))
(define-module (test-suite tests compiler)
:use-module (test-suite lib)
:use-module (test-suite guile-test)
- :use-module (system base compile))
+ :use-module (system base compile)
+ :use-module ((system vm vm) #:select (the-vm vm-load)))
+
+(define read-and-compile
+ (@@ (system base compile) read-and-compile))
\f
\f
(with-test-prefix "psyntax"
- (pass-if "redefinition"
- ;; In this case the locally-bound `round' must have the same value as the
- ;; imported `round'. See the same test in `syntax.test' for details.
+ (pass-if "compile uses a fresh module by default"
(begin
- (compile '(define round round))
- (compile '(eq? round (@@ (guile) round)))))
+ (compile '(define + -))
+ (eq? (compile '+) +)))
+
+ (pass-if "compile-time definitions are isolated"
+ (begin
+ (compile '(define foo-bar #t))
+ (not (module-variable (current-module) 'foo-bar))))
(pass-if "compile in current module"
(let ((o (begin
- (compile '(define-macro (foo) 'bar))
- (compile '(let ((bar 'ok)) (foo))))))
- (and (module-ref (current-module) 'foo)
+ (compile '(define-macro (foo) 'bar)
+ #:env (current-module))
+ (compile '(let ((bar 'ok)) (foo))
+ #:env (current-module)))))
+ (and (macro? (module-ref (current-module) 'foo))
(eq? o 'ok))))
(pass-if "compile in fresh module"
(compile '(define-macro (foo) 'bar) #:env m)
(compile '(let ((bar 'ok)) (foo)) #:env m))))
(and (module-ref m 'foo)
- (eq? o 'ok)))))
+ (eq? o 'ok))))
+
+ (pass-if "redefinition"
+ ;; In this case the locally-bound `round' must have the same value as the
+ ;; imported `round'. See the same test in `syntax.test' for details.
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+ (compile '(define round round) #:env m)
+ (eq? round (module-ref m 'round)))))
+
+\f
+(with-test-prefix "current-reader"
+
+ (pass-if "default compile-time current-reader differs"
+ (not (eq? (compile 'current-reader)
+ current-reader)))
+
+ (pass-if "compile-time changes are honored and isolated"
+ ;; Make sure changing `current-reader' as the side-effect of a defmacro
+ ;; actually works.
+ (let ((r (fluid-ref current-reader))
+ (input (open-input-string
+ "(define-macro (install-reader!)
+ ;;(format #t \"current-reader = ~A~%\" current-reader)
+ (fluid-set! current-reader
+ (let ((first? #t))
+ (lambda args
+ (if first?
+ (begin
+ (set! first? #f)
+ ''ok)
+ (read (open-input-string \"\"))))))
+ #f)
+ (install-reader!)
+ this-should-be-ignored")))
+ (and (eq? (vm-load (the-vm) (read-and-compile input))
+ 'ok)
+ (eq? r (fluid-ref current-reader)))))
+
+ (pass-if "with eval-when"
+ (let ((r (fluid-ref current-reader)))
+ (compile '(eval-when (compile eval)
+ (fluid-set! current-reader (lambda args 'chbouib))))
+ (eq? (fluid-ref current-reader) r))))
;;;; -*- scheme -*-
;;;; continuations.test --- test suite for continutations
;;;;
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2009 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
(pass-if "throwing to a rewound catch context"
(eq? (dont-crash-please) 'no-reentry))
+ (pass-if "can print a continuation"
+ (let ((s (with-output-to-string
+ (lambda ()
+ (call-with-current-continuation write)))))
+ (string=? "#<continuation " (substring s 0 15))))
+
+ (pass-if "blocked attempt to cross a continuation barrier"
+ (call-with-current-continuation
+ (lambda (k)
+ (with-continuation-barrier
+ (lambda ()
+ (catch 'misc-error
+ (lambda ()
+ (k 1)
+ #f)
+ (lambda _
+ #t)))))))
+
+ (pass-if "uncaught exception is handled by continuation barrier"
+ (let* ((handled #f)
+ (s (with-error-to-string
+ (lambda ()
+ (set! handled
+ (not (with-continuation-barrier
+ (lambda ()
+ (error "Catch me if you can!")))))))))
+ handled))
+
(with-debugging-evaluator
(pass-if "make a stack from a continuation"
(pass-if "get a continuation's stack ID"
(let ((id (call-with-current-continuation stack-id)))
- (or (boolean? id) (symbol? id))))
-
- (pass-if "get a continuation's innermost frame"
- (pair? (call-with-current-continuation last-stack-frame))))
+ (or (boolean? id) (symbol? id)))))
)
;;;; elisp.test --- tests guile's elisp support -*- scheme -*-
-;;;; Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2002, 2003, 2006, 2009 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
:use-module (test-suite lib)
:use-module (ice-9 weak-vector))
+;; FIXME: the test suite is good, but it uses the old lang elisp module
+;; instead of the new code. Disable for now.
+'(
+
(define *old-stack-level* (and=> (memq 'stack (debug-options)) cadr))
(if *old-stack-level*
(debug-set! stack (* 2 *old-stack-level*)))
(set! %load-should-autocompile *old-%load-should-autocompile*)
(debug-set! stack *old-stack-level*)
+)
;;; elisp.test ends here
;;;; encoding-escapes.test --- test suite for Guile's string encodings -*- mode: scheme; coding: utf-8 -*-
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;;
+;;;; 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 General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 USA
+;;;; 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
(define-module (test-strings)
#:use-module (test-suite lib)
(string=? "\\xfaltima"
(get-output-string pt))))
(pass-if "Rashomon"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ASCII")
- (set-port-conversion-strategy! pt 'escape)
- (display s4 pt)
- (string=? "\\u7F85\\u751F\\u9580"
- (get-output-string pt)))))
-
-(setlocale LC_ALL "en_US.utf8")
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'escape)
+ (display s4 pt)
+ (string=? "\\u7F85\\u751F\\u9580"
+ (get-output-string pt)))))
(with-test-prefix "input escapes"
- (pass-if "última"
- (string=? "última"
- (with-input-from-string "\"\\xfaltima\"" read)))
+ (pass-if "última"
+ (with-locale "en_US.utf8"
+ (string=? "última"
+ (with-input-from-string "\"\\xfaltima\"" read))))
(pass-if "羅生門"
- (string=? "羅生門"
- (with-input-from-string "\"\\u7F85\\u751F\\u9580\"" read))))
+ (with-locale "en_US.utf8"
+ (string=? "羅生門"
+ (with-input-from-string
+ "\"\\u7F85\\u751F\\u9580\"" read)))))
-;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: iso-8859-1 -*-
+;;;; encoding-iso88591.test --- test suite for Guile's string encodings -*- mode: scheme; coding: iso-8859-1 -*-
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;;
+;;;; 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 General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 USA
+;;;; 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
(define-module (test-strings)
#:use-module (test-suite lib)
(define (string-ints . args)
(apply string (map integer->char args)))
-(setlocale LC_ALL "")
+;; Set locale to the environment's locale, so that the prints look OK.
+(define oldlocale #f)
+(if (defined? 'setlocale)
+ (set! oldlocale (setlocale LC_ALL "")))
+
+(define ascii-a (integer->char 65)) ; LATIN CAPITAL LETTER A
+(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
+(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
+(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A
+
+(with-test-prefix "characters"
+ (pass-if "input A"
+ (char=? ascii-a #\A))
+
+ (pass-if "input A acute"
+ (char=? a-acute #\Á))
+
+ (pass-if "display A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (display ascii-a pt)
+ (string=? "A"
+ (get-output-string pt))))
+
+ (pass-if "display A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (display a-acute pt)
+ (string=? "Á"
+ (get-output-string pt))))
+
+ (pass-if "display alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (display alpha pt)
+ (string-ci=? "\\u03b1"
+ (get-output-string pt))))
+
+ (pass-if "display Cherokee a"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (display cherokee-a pt)
+ (string-ci=? "\\u13a0"
+ (get-output-string pt))))
+
+ (pass-if "write A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (write ascii-a pt)
+ (string=? "#\\A"
+ (get-output-string pt))))
+
+ (pass-if "write A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (write a-acute pt)
+ (string=? "#\\Á"
+ (get-output-string pt)))))
+
(define s1 "última")
(define s2 "cédula")
(list= eqv? (string->list s4)
(list #\¿ #\C #\ó #\m #\o #\?))))
-;; Check that the output is in ISO-8859-1 encoding
-(with-test-prefix "display"
-
- (pass-if "s1"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ISO-8859-1")
- (display s1 pt)
- (list= eqv?
- (list #xfa #x6c #x74 #x69 #x6d #x61)
- (u8vector->list
- (get-output-locale-u8vector pt)))))
-
- (pass-if "s2"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ISO-8859-1")
- (display s2 pt)
- (list= eqv?
- (list #x63 #xe9 #x64 #x75 #x6c #x61)
- (u8vector->list
- (get-output-locale-u8vector pt))))))
-
(with-test-prefix "symbols == strings"
(pass-if "última"
(display (string-ints 256) pt))))
;; Reset locales
-(setlocale LC_ALL "C")
\ No newline at end of file
+(if (defined? 'setlocale)
+ (setlocale LC_ALL oldlocale))
-;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: iso-8859-7 -*-
+;;;; encoding-iso88697.test --- test suite for Guile's string encodings -*- mode: scheme; coding: iso-8859-7 -*-
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;;
+;;;; 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 General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 USA
+;;;; 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
(define-module (test-strings)
#:use-module (test-suite lib)
(define (string-ints . args)
(apply string (map integer->char args)))
-(setlocale LC_ALL "")
+(define oldlocale #f)
+(if (defined? 'setlocale)
+ (set! oldlocale (setlocale LC_ALL "")))
+(define ascii-a (integer->char 65)) ; LATIN CAPITAL LETTER A
+(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
+(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
+(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A
+
+(with-test-prefix "characters"
+ (pass-if "input A"
+ (char=? ascii-a #\A))
+
+ (pass-if "input alpha"
+ (char=? alpha #\á))
+
+ (pass-if "display A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (display ascii-a pt)
+ (string=? "A"
+ (get-output-string pt))))
+
+ (pass-if "display A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (display a-acute pt)
+ (string-ci=? "\\xc1"
+ (get-output-string pt))))
+
+ (pass-if "display alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (display alpha pt)
+ (string-ci=? "á"
+ (get-output-string pt))))
+
+ (pass-if "display Cherokee A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (display cherokee-a pt)
+ (string-ci=? "\\u13a0"
+ (get-output-string pt))))
+
+ (pass-if "write A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (write ascii-a pt)
+ (string=? "#\\A"
+ (get-output-string pt))))
+
+ (pass-if "write alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (write alpha pt)
+ (string=? "#\\á"
+ (get-output-string pt)))))
(define s1 "Ðåñß")
(define s2 "ôçò")
(list= eqv? (string->list s4)
(list #\ê #\á #\é))))
-;; Testing that the display of the string is output in the ISO-8859-7
-;; encoding
-(with-test-prefix "display"
-
- (pass-if "s1"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ISO-8859-7")
- (display s1 pt)
- (list= eqv?
- (list #xd0 #xe5 #xf1 #xdf)
- (u8vector->list
- (get-output-locale-u8vector pt)))))
- (pass-if "s2"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ISO-8859-7")
- (display s2 pt)
- (list= eqv?
- (list #xf4 #xe7 #xf2)
- (u8vector->list
- (get-output-locale-u8vector pt))))))
-
(with-test-prefix "symbols == strings"
(pass-if "Ðåñß"
(display (string-ints #x0400) pt))))
;; Reset locale
-(setlocale LC_ALL "C")
\ No newline at end of file
+(if (defined? 'setlocale)
+ (setlocale LC_ALL oldlocale))
-;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: utf-8 -*-
+;;;; encoding-utf8.test --- test suite for Guile's string encodings -*- mode: scheme; coding: utf-8 -*-
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;;
+;;;; 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 General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 USA
+;;;; 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
(define-module (test-strings)
#:use-module (test-suite lib)
(define (string-ints . args)
(apply string (map integer->char args)))
-(setlocale LC_ALL "")
+(define oldlocale #f)
+(if (defined? 'setlocale)
+ (set! oldlocale (setlocale LC_ALL "")))
+
+(define ascii-a (integer->char 65)) ; LATIN CAPITAL LETTER A
+(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
+(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
+(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A
+
+(with-test-prefix "characters"
+ (pass-if "input A"
+ (char=? ascii-a #\A))
+
+ (pass-if "input A acute"
+ (char=? a-acute #\Á))
+
+ (pass-if "input alpha"
+ (char=? alpha #\α))
+
+ (pass-if "input Cherokee A"
+ (char=? cherokee-a #\Ꭰ))
+
+ (pass-if "display A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display ascii-a pt)
+ (string=? "A"
+ (get-output-string pt))))
+
+ (pass-if "display A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display a-acute pt)
+ (string=? "Á"
+ (get-output-string pt))))
+
+ (pass-if "display alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display alpha pt)
+ (string-ci=? "α"
+ (get-output-string pt))))
+
+ (pass-if "display Cherokee A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display cherokee-a pt)
+ (string-ci=? "Ꭰ"
+ (get-output-string pt))))
+
+ (pass-if "write A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'escape)
+ (write ascii-a pt)
+ (string=? "#\\A"
+ (get-output-string pt))))
+
+ (pass-if "write A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'escape)
+ (write a-acute pt)
+ (string=? "#\\Á"
+ (get-output-string pt))))
+
+ (pass-if "write alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'escape)
+ (write alpha pt)
+ (string=? "#\\α"
+ (get-output-string pt))))
+
+ (pass-if "write Cherokee A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'escape)
+ (write cherokee-a pt)
+ (string=? "#\\Ꭰ"
+ (get-output-string pt)))))
(define s1 "última")
(define s2 "cédula")
(ñ 2))
(eq? (+ 芥川龍之介 ñ) 3))))
-
+(if (defined? 'setlocale)
+ (setlocale LC_ALL oldlocale))
+++ /dev/null
-;;;; environments.test -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006 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
-
-(use-modules (ice-9 documentation))
-
-;;; environments are currently commented out of libguile, so these
-;;; tests must be commented out also. - NJ 2006-11-02.
-(if #f (let ()
-
-;;;
-;;; miscellaneous
-;;;
-
-(define exception:unbound-symbol
- (cons 'misc-error "^Symbol .* not bound in environment"))
-
-(define (documented? object)
- (not (not (object-documentation object))))
-
-(define (folder sym val res)
- (cons (cons sym val) res))
-
-(define (make-observer-func)
- (let* ((counter 0))
- (lambda args
- (if (null? args)
- counter
- (set! counter (+ counter 1))))))
-
-(define (make-erroneous-observer-func)
- (let* ((func (make-observer-func)))
- (lambda args
- (if (null? args)
- (func)
- (begin
- (func args)
- (error))))))
-
-;;;
-;;; leaf-environments
-;;;
-
-(with-test-prefix "leaf-environments"
-
- (with-test-prefix "leaf-environment?"
-
- (pass-if "documented?"
- (documented? leaf-environment?))
-
- (pass-if "non-environment-object"
- (not (leaf-environment? #f))))
-
-
- (with-test-prefix "make-leaf-environment"
-
- (pass-if "documented?"
- (documented? make-leaf-environment))
-
- (pass-if "produces an environment"
- (environment? (make-leaf-environment)))
-
- (pass-if "produces a leaf-environment"
- (leaf-environment? (make-leaf-environment)))
-
- (pass-if "produces always a new environment"
- (not (eq? (make-leaf-environment) (make-leaf-environment)))))
-
-
- (with-test-prefix "bound, define, ref, set!, cell"
-
- (pass-if "symbols are unbound by default"
- (let* ((env (make-leaf-environment)))
- (and (not (environment-bound? env 'a))
- (not (environment-bound? env 'b))
- (not (environment-bound? env 'c)))))
-
- (pass-if "symbol is bound after define"
- (let* ((env (make-leaf-environment)))
- (environment-bound? env 'a)
- (environment-define env 'a #t)
- (environment-bound? env 'a)))
-
- (pass-if "ref a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-bound? env 'a)
- (environment-bound? env 'b)
- (environment-define env 'a #t)
- (environment-define env 'b #f)
- (and (environment-ref env 'a)
- (not (environment-ref env 'b)))))
-
- (pass-if "set! a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (environment-define env 'b #f)
- (environment-ref env 'a)
- (environment-ref env 'b)
- (environment-set! env 'a #f)
- (environment-set! env 'b #t)
- (and (not (environment-ref env 'a))
- (environment-ref env 'b))))
-
- (pass-if "get a read-only cell"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (let* ((cell (environment-cell env 'a #f)))
- (and (cdr cell)
- (begin
- (environment-set! env 'a #f)
- (not (cdr cell)))))))
-
- (pass-if "a read-only cell gets rebound after define"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (let* ((cell (environment-cell env 'a #f)))
- (environment-define env 'a #f)
- (not (eq? (environment-cell env 'a #f) cell)))))
-
- (pass-if "get a writable cell"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (let* ((readable (environment-cell env 'a #f))
- (writable (environment-cell env 'a #t)))
- (and (eq? readable writable)
- (begin
- (environment-set! env 'a #f)
- (not (cdr writable)))
- (begin
- (set-cdr! writable #t)
- (environment-ref env 'a))
- (begin
- (set-cdr! (environment-cell env 'a #t) #f)
- (not (cdr writable)))))))
-
- (pass-if "a writable cell gets rebound after define"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (let* ((cell (environment-cell env 'a #t)))
- (environment-define env 'a #f)
- (not (eq? (environment-cell env 'a #t) cell)))))
-
- (pass-if-exception "reference an unbound symbol"
- exception:unbound-symbol
- (environment-ref (make-leaf-environment) 'a))
-
- (pass-if-exception "set! an unbound symbol"
- exception:unbound-symbol
- (environment-set! (make-leaf-environment) 'a #f))
-
- (pass-if-exception "get a readable cell for an unbound symbol"
- exception:unbound-symbol
- (environment-cell (make-leaf-environment) 'a #f))
-
- (pass-if-exception "get a writable cell for an unbound symbol"
- exception:unbound-symbol
- (environment-cell (make-leaf-environment) 'a #t)))
-
-
- (with-test-prefix "undefine"
-
- (pass-if "undefine a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (environment-ref env 'a)
- (environment-undefine env 'a)
- (not (environment-bound? env 'a))))
-
- (pass-if "undefine an already undefined symbol"
- (environment-undefine (make-leaf-environment) 'a)
- #t))
-
-
- (with-test-prefix "fold"
-
- (pass-if "empty environment"
- (let* ((env (make-leaf-environment)))
- (eq? 'success (environment-fold env folder 'success))))
-
- (pass-if "one symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (equal? '((a . #t)) (environment-fold env folder '()))))
-
- (pass-if "two symbols"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (environment-define env 'b #f)
- (let ((folded (environment-fold env folder '())))
- (or (equal? folded '((a . #t) (b . #f)))
- (equal? folded '((b . #f) (a . #t))))))))
-
-
- (with-test-prefix "observe"
-
- (pass-if "observe an environment"
- (let* ((env (make-leaf-environment)))
- (environment-observe env (make-observer-func))
- #t))
-
- (pass-if "observe an environment twice"
- (let* ((env (make-leaf-environment))
- (observer-1 (environment-observe env (make-observer-func)))
- (observer-2 (environment-observe env (make-observer-func))))
- (not (eq? observer-1 observer-2))))
-
- (pass-if "definition of an undefined symbol"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe env func)
- (environment-define env 'a 1)
- (eqv? (func) 1)))
-
- (pass-if "definition of an already defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-define env 'a 1)
- (eqv? (func) 1))))
-
- (pass-if "set!ing of a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-set! env 'a 1)
- (eqv? (func) 0))))
-
- (pass-if "undefining a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-undefine env 'a)
- (eqv? (func) 1))))
-
- (pass-if "undefining an already undefined symbol"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe env func)
- (environment-undefine env 'a)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an active observer"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func))
- (observer (environment-observe env func)))
- (environment-unobserve observer)
- (environment-define env 'a 1)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an inactive observer"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func))
- (observer (environment-observe env func)))
- (environment-unobserve observer)
- (environment-unobserve observer)
- #t)))
-
-
- (with-test-prefix "observe-weak"
-
- (pass-if "observe an environment"
- (let* ((env (make-leaf-environment)))
- (environment-observe-weak env (make-observer-func))
- #t))
-
- (pass-if "observe an environment twice"
- (let* ((env (make-leaf-environment))
- (observer-1 (environment-observe-weak env (make-observer-func)))
- (observer-2 (environment-observe-weak env (make-observer-func))))
- (not (eq? observer-1 observer-2))))
-
- (pass-if "definition of an undefined symbol"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-define env 'a 1)
- (eqv? (func) 1)))
-
- (pass-if "definition of an already defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-define env 'a 1)
- (eqv? (func) 1))))
-
- (pass-if "set!ing of a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-set! env 'a 1)
- (eqv? (func) 0))))
-
- (pass-if "undefining a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-undefine env 'a)
- (eqv? (func) 1))))
-
- (pass-if "undefining an already undefined symbol"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-undefine env 'a)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an active observer"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func))
- (observer (environment-observe-weak env func)))
- (environment-unobserve observer)
- (environment-define env 'a 1)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an inactive observer"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func))
- (observer (environment-observe-weak env func)))
- (environment-unobserve observer)
- (environment-unobserve observer)
- #t))
-
- (pass-if "weak observer gets collected"
- (gc)
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (gc)
- (environment-define env 'a 1)
- (if (not (eqv? (func) 0))
- (throw 'unresolved) ; note: conservative scanning
- #t))))
-
-
- (with-test-prefix "erroneous observers"
-
- (pass-if "update continues after error"
- (let* ((env (make-leaf-environment))
- (func-1 (make-erroneous-observer-func))
- (func-2 (make-erroneous-observer-func)))
- (environment-observe env func-1)
- (environment-observe env func-2)
- (catch #t
- (lambda ()
- (environment-define env 'a 1)
- #f)
- (lambda args
- (and (eq? (func-1) 1)
- (eq? (func-2) 1))))))))
-
-
-;;;
-;;; leaf-environment based eval-environments
-;;;
-
-(with-test-prefix "leaf-environment based eval-environments"
-
- (with-test-prefix "eval-environment?"
-
- (pass-if "documented?"
- (documented? eval-environment?))
-
- (pass-if "non-environment-object"
- (not (eval-environment? #f)))
-
- (pass-if "leaf-environment-object"
- (not (eval-environment? (make-leaf-environment)))))
-
-
- (with-test-prefix "make-eval-environment"
-
- (pass-if "documented?"
- (documented? make-eval-environment))
-
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment)))
-
- (pass-if "produces an environment"
- (environment? (make-eval-environment local imported)))
-
- (pass-if "produces an eval-environment"
- (eval-environment? (make-eval-environment local imported)))
-
- (pass-if "produces always a new environment"
- (not (eq? (make-eval-environment local imported)
- (make-eval-environment local imported))))))
-
-
- (with-test-prefix "eval-environment-local"
-
- (pass-if "documented?"
- (documented? eval-environment-local))
-
- (pass-if "returns local"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (eq? (eval-environment-local env) local))))
-
-
- (with-test-prefix "eval-environment-imported"
-
- (pass-if "documented?"
- (documented? eval-environment-imported))
-
- (pass-if "returns imported"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (eq? (eval-environment-imported env) imported))))
-
-
- (with-test-prefix "bound, define, ref, set!, cell"
-
- (pass-if "symbols are unbound by default"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (and (not (environment-bound? env 'a))
- (not (environment-bound? env 'b))
- (not (environment-bound? env 'c)))))
-
- (with-test-prefix "symbols bound in imported"
-
- (pass-if "binding is visible"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-bound? env 'a)
- (environment-define imported 'a #t)
- (environment-bound? env 'a)))
-
- (pass-if "ref works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-bound? env 'a)
- (environment-define imported 'a #t)
- (environment-ref env 'a)))
-
- (pass-if "set! works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #f)
- (environment-set! env 'a #t)
- (environment-ref imported 'a)))
-
- (pass-if "cells are passed through"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (let* ((imported-cell (environment-cell imported 'a #f))
- (env-cell (environment-cell env 'a #f)))
- (eq? env-cell imported-cell)))))
-
- (with-test-prefix "symbols bound in local"
-
- (pass-if "binding is visible"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-bound? env 'a)
- (environment-define local 'a #t)
- (environment-bound? env 'a)))
-
- (pass-if "ref works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (environment-ref env 'a)))
-
- (pass-if "set! works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #f)
- (environment-set! env 'a #t)
- (environment-ref local 'a)))
-
- (pass-if "cells are passed through"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (let* ((local-cell (environment-cell local 'a #f))
- (env-cell (environment-cell env 'a #f)))
- (eq? env-cell local-cell)))))
-
- (with-test-prefix "symbols bound in local and imported"
-
- (pass-if "binding is visible"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-bound? env 'a)
- (environment-define imported 'a #t)
- (environment-define local 'a #f)
- (environment-bound? env 'a)))
-
- (pass-if "ref works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #f)
- (environment-define local 'a #t)
- (environment-ref env 'a)))
-
- (pass-if "set! changes local"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #f)
- (environment-define local 'a #f)
- (environment-set! env 'a #t)
- (environment-ref local 'a)))
-
- (pass-if "set! does not touch imported"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (environment-define local 'a #t)
- (environment-set! env 'a #f)
- (environment-ref imported 'a)))
-
- (pass-if "cells from local are passed through"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (let* ((local-cell (environment-cell local 'a #f))
- (env-cell (environment-cell env 'a #f)))
- (eq? env-cell local-cell)))))
-
- (with-test-prefix "defining symbols"
-
- (pass-if "symbols are bound in local after define"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a #t)
- (environment-bound? local 'a)))
-
- (pass-if "cells in local get rebound after define"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a #f)
- (let* ((old-cell (environment-cell local 'a #f)))
- (environment-define env 'a #f)
- (let* ((new-cell (environment-cell local 'a #f)))
- (not (eq? new-cell old-cell))))))
-
- (pass-if "cells in imported get shadowed after define"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #f)
- (environment-define env 'a #t)
- (environment-ref local 'a))))
-
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
-
- (pass-if-exception "reference an unbound symbol"
- exception:unbound-symbol
- (environment-ref env 'b))
-
- (pass-if-exception "set! an unbound symbol"
- exception:unbound-symbol
- (environment-set! env 'b #f))
-
- (pass-if-exception "get a readable cell for an unbound symbol"
- exception:unbound-symbol
- (environment-cell env 'b #f))
-
- (pass-if-exception "get a writable cell for an unbound symbol"
- exception:unbound-symbol
- (environment-cell env 'b #t))))
-
- (with-test-prefix "eval-environment-set-local!"
-
- (pass-if "documented?"
- (documented? eval-environment-set-local!))
-
- (pass-if "new binding becomes visible"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-bound? env 'a)
- (environment-define new-local 'a #t)
- (eval-environment-set-local! env new-local)
- (environment-bound? env 'a)))
-
- (pass-if "existing binding is replaced"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define old-local 'a #f)
- (environment-ref env 'a)
- (environment-define new-local 'a #t)
- (eval-environment-set-local! env new-local)
- (environment-ref env 'a)))
-
- (pass-if "undefined binding is removed"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define old-local 'a #f)
- (environment-ref env 'a)
- (eval-environment-set-local! env new-local)
- (not (environment-bound? env 'a))))
-
- (pass-if "binding in imported remains shadowed"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define imported 'a #f)
- (environment-define old-local 'a #f)
- (environment-ref env 'a)
- (environment-define new-local 'a #t)
- (eval-environment-set-local! env new-local)
- (environment-ref env 'a)))
-
- (pass-if "binding in imported gets shadowed"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define imported 'a #f)
- (environment-ref env 'a)
- (environment-define new-local 'a #t)
- (eval-environment-set-local! env new-local)
- (environment-ref env 'a)))
-
- (pass-if "binding in imported becomes visible"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define imported 'a #t)
- (environment-define old-local 'a #f)
- (environment-ref env 'a)
- (eval-environment-set-local! env new-local)
- (environment-ref env 'a))))
-
- (with-test-prefix "eval-environment-set-imported!"
-
- (pass-if "documented?"
- (documented? eval-environment-set-imported!))
-
- (pass-if "new binding becomes visible"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-bound? env 'a)
- (environment-define new-imported 'a #t)
- (eval-environment-set-imported! env new-imported)
- (environment-bound? env 'a)))
-
- (pass-if "existing binding is replaced"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-define old-imported 'a #f)
- (environment-ref env 'a)
- (environment-define new-imported 'a #t)
- (eval-environment-set-imported! env new-imported)
- (environment-ref env 'a)))
-
- (pass-if "undefined binding is removed"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-define old-imported 'a #f)
- (environment-ref env 'a)
- (eval-environment-set-imported! env new-imported)
- (not (environment-bound? env 'a))))
-
- (pass-if "binding in imported remains shadowed"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-define local 'a #t)
- (environment-define old-imported 'a #f)
- (environment-ref env 'a)
- (environment-define new-imported 'a #t)
- (eval-environment-set-imported! env new-imported)
- (environment-ref env 'a)))
-
- (pass-if "binding in imported gets shadowed"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-define local 'a #t)
- (environment-ref env 'a)
- (environment-define new-imported 'a #f)
- (eval-environment-set-imported! env new-imported)
- (environment-ref env 'a))))
-
- (with-test-prefix "undefine"
-
- (pass-if "undefine an already undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-undefine env 'a)
- #t))
-
- (pass-if "undefine removes a binding from local"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (environment-undefine env 'a)
- (not (environment-bound? local 'a))))
-
- (pass-if "undefine does not influence imported"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (environment-undefine env 'a)
- (environment-bound? imported 'a)))
-
- (pass-if "undefine an imported symbol does not undefine it"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (environment-undefine env 'a)
- (environment-bound? env 'a)))
-
- (pass-if "undefine unshadows an imported symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (environment-define local 'a #f)
- (environment-undefine env 'a)
- (environment-ref env 'a))))
-
- (with-test-prefix "fold"
-
- (pass-if "empty environment"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (eq? 'success (environment-fold env folder 'success))))
-
- (pass-if "one symbol in local"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (equal? '((a . #t)) (environment-fold env folder '()))))
-
- (pass-if "one symbol in imported"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (equal? '((a . #t)) (environment-fold env folder '()))))
-
- (pass-if "shadowed symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (environment-define imported 'a #f)
- (equal? '((a . #t)) (environment-fold env folder '()))))
-
- (pass-if "one symbol each"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (environment-define imported 'b #f)
- (let ((folded (environment-fold env folder '())))
- (or (equal? folded '((a . #t) (b . #f)))
- (equal? folded '((b . #f) (a . #t))))))))
-
-
- (with-test-prefix "observe"
-
- (pass-if "observe an environment"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-observe env (make-observer-func))
- #t))
-
- (pass-if "observe an environment twice"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (observer-1 (environment-observe env (make-observer-func)))
- (observer-2 (environment-observe env (make-observer-func))))
- (not (eq? observer-1 observer-2))))
-
- (pass-if "definition of an undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe env func)
- (environment-define env 'a 1)
- (eqv? (func) 1)))
-
- (pass-if "definition of an already defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-define env 'a 1)
- (eqv? (func) 1))))
-
- (pass-if "set!ing of a defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-set! env 'a 1)
- (eqv? (func) 0))))
-
- (pass-if "undefining a defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-undefine env 'a)
- (eqv? (func) 1))))
-
- (pass-if "undefining an already undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe env func)
- (environment-undefine env 'a)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an active observer"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func))
- (observer (environment-observe env func)))
- (environment-unobserve observer)
- (environment-define env 'a 1)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an inactive observer"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func))
- (observer (environment-observe env func)))
- (environment-unobserve observer)
- (environment-unobserve observer)
- #t)))
-
-
- (with-test-prefix "observe-weak"
-
- (pass-if "observe an environment"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-observe-weak env (make-observer-func))
- #t))
-
- (pass-if "observe an environment twice"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (observer-1 (environment-observe-weak env (make-observer-func)))
- (observer-2 (environment-observe-weak env (make-observer-func))))
- (not (eq? observer-1 observer-2))))
-
- (pass-if "definition of an undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-define env 'a 1)
- (eqv? (func) 1)))
-
- (pass-if "definition of an already defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-define env 'a 1)
- (eqv? (func) 1))))
-
- (pass-if "set!ing of a defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-set! env 'a 1)
- (eqv? (func) 0))))
-
- (pass-if "undefining a defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-undefine env 'a)
- (eqv? (func) 1))))
-
- (pass-if "undefining an already undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-undefine env 'a)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an active observer"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func))
- (observer (environment-observe-weak env func)))
- (environment-unobserve observer)
- (environment-define env 'a 1)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an inactive observer"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func))
- (observer (environment-observe-weak env func)))
- (environment-unobserve observer)
- (environment-unobserve observer)
- #t))
-
- (pass-if "weak observer gets collected"
- (gc)
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (gc)
- (environment-define env 'a 1)
- (if (not (eqv? (func) 0))
- (throw 'unresolved) ; note: conservative scanning
- #t))))
-
-
- (with-test-prefix "erroneous observers"
-
- (pass-if "update continues after error"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func-1 (make-erroneous-observer-func))
- (func-2 (make-erroneous-observer-func)))
- (environment-observe env func-1)
- (environment-observe env func-2)
- (catch #t
- (lambda ()
- (environment-define env 'a 1)
- #f)
- (lambda args
- (and (eq? (func-1) 1)
- (eq? (func-2) 1))))))))
-
-
-;;;
-;;; leaf-environment based import-environments
-;;;
-
-(with-test-prefix "leaf-environment based import-environments"
-
- (with-test-prefix "import-environment?"
-
- (pass-if "documented?"
- (documented? import-environment?))
-
- (pass-if "non-environment-object"
- (not (import-environment? #f)))
-
- (pass-if "leaf-environment-object"
- (not (import-environment? (make-leaf-environment))))
-
- (pass-if "eval-environment-object"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (not (import-environment? (make-leaf-environment))))))
-
-
- (with-test-prefix "make-import-environment"
-
- (pass-if "documented?"
- (documented? make-import-environment))))
-
-;;; End of commenting out. - NJ 2006-11-02.
-))
(equal? bar '(#t . #(#t)))))
(pass-if-exception "circular lists in forms"
- exception:bad-expression
+ exception:wrong-type-arg
(let ((foo (list #f)))
(set-cdr! foo foo)
(copy-tree foo))))
(with-test-prefix "scm_tc7_subr_2o"
;; prior to guile 1.6.9 and 1.8.1 this called the function with
- ;; SCM_UNDEFIEND, which in the case of make-vector resulted in
+ ;; SCM_UNDEFINED, which in the case of make-vector resulted in
;; wrong-type-arg, instead of the intended wrong-num-args
(pass-if-exception "0 args" exception:wrong-num-args
(apply make-vector '()))
(with-test-prefix "define set procedure-name"
- (pass-if "closure"
+ (expect-fail "closure"
(eq? 'foo-closure (procedure-name bar-closure)))
- (pass-if "procedure-with-setter"
+ (expect-fail "procedure-with-setter"
(eq? 'foo-pws (procedure-name bar-pws))))
(if old-procnames-flag
;; The subr involving the error must appear exactly once on the stack.
(catch 'result
(lambda ()
+ (throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
;; application.
(catch 'result
(lambda ()
+ (throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
hashq-ref)))
frames)))))))
(lambda (key result)
- (= 1 result))))))
+ (= 1 result))))
+
+ (pass-if "arguments of a gsubr stack frame"
+ ;; Create a stack with two gsubr frames and make sure the arguments are
+ ;; correct.
+ (catch 'result
+ (lambda ()
+ (throw 'unresolved)
+ (start-stack 'foo
+ (lazy-catch 'wrong-type-arg
+ (lambda ()
+ ;; Trigger a `wrong-type-arg' exception.
+ (substring 'wrong 'type 'arg))
+ (lambda _
+ (let* ((stack (make-stack #t))
+ (frames (stack->frames stack)))
+ (throw 'result
+ (map (lambda (frame)
+ (cons (frame-procedure frame)
+ (frame-arguments frame)))
+ frames)))))))
+ (lambda (key result)
+ (and (equal? (car result) `(,make-stack #t))
+ (pair? (member `(,substring wrong type arg)
+ (cdr result)))))))))
;;;
;;; letrec init evaluation
;;;; gc.test --- test guile's garbage collection -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009 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
(with-test-prefix "gc"
(pass-if "Unused modules are removed"
- (let*
- ((dummy (gc))
- (last-count (cdr (assoc
- "eval-closure" (gc-live-object-stats)))))
-
- (for-each (lambda (x) (make-module)) (iota 1000))
-
- ;; XXX: This hack aims to clean up the stack to make sure we
- ;; don't leave a reference to one of the modules we created. It
- ;; proved to be useful on SPARC:
- ;; http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00006.html .
- (let cleanup ((i 10))
- (and (> i 0)
- (begin (cleanup (1- i)) i)))
-
- (gc)
+ (let* ((guard (make-guardian))
+ (total 1000))
+
+ (for-each (lambda (x) (guard (make-module))) (iota total))
+
+ (gc)
(gc) ;; twice: have to kill the weak vectors.
- (= last-count (cdr (assoc "eval-closure" (gc-live-object-stats)))))
- ))
+ (gc) ;; thrice: because the test doesn't succeed with only
+ ;; one gc round. not sure why.
+
+ (= (let lp ((i 0))
+ (if (guard)
+ (lp (1+ i))
+ i))
+ total))))
+
#:use-module (test-suite lib)
#:autoload (srfi srfi-1) (unfold))
+(define exception:no-applicable-method
+ '(goops-error . "^No applicable method"))
+
(pass-if "GOOPS loads"
(false-if-exception
(begin (resolve-module '(oop goops))
(eq? (class-of "foo") <string>))
(pass-if "port"
- (is-a? (%make-void-port "w") <port>)))
+ (is-a? (%make-void-port "w") <port>))
+
+ (pass-if "struct vtable"
+ ;; Previously, `class-of' would fail for nameless structs, i.e., structs
+ ;; for which `struct-vtable-name' is #f.
+ (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
(with-test-prefix "defining classes"
(eval '(is-a? <foo> <class>) (current-module)))
(expect-fail "bad init-thunk"
- (catch #t
- (lambda ()
- (eval '(define-class <foo> ()
- (x #:init-thunk (lambda (x) 1)))
- (current-module))
- #t)
- (lambda args
- #f)))
+ (begin
+ ;; Currently UPASSing because we can't usefully get
+ ;; any arity information out of interpreted
+ ;; procedures. A FIXME I guess.
+ (throw 'unresolved)
+ (catch #t
+ (lambda ()
+ (eval '(define-class <foo> ()
+ (x #:init-thunk (lambda (x) 1)))
+ (current-module))
+ #t)
+ (lambda args
+ #f))))
(pass-if "interaction with `struct-ref'"
(eval '(define-class <class-struct> ()
(define o4 (make <c> #:x '(4) #:y '(3)))
(not (eqv? o1 o2)))
(current-module)))
- (pass-if "eqv?"
- (eval '(begin
- (define-method (eqv? (a <c>) (b <c>))
- (equal? (x a) (x b)))
- (eqv? o1 o2))
- (current-module)))
- (pass-if "not eqv?"
- (eval '(not (eqv? o2 o3))
- (current-module)))
- (pass-if "transfer eqv? => equal?"
- (eval '(equal? o1 o2)
- (current-module)))
(pass-if "equal?"
(eval '(begin
(define-method (equal? (a <c>) (b <c>))
(= (x (o2 o)) 3)
(= (y (o2 o)) 5)))
(current-module))))
+
+(with-test-prefix "no-applicable-method"
+ (pass-if-exception "calling generic, no methods"
+ exception:no-applicable-method
+ (eval '(begin
+ (define-class <qux> ())
+ (define-generic quxy)
+ (quxy 1))
+ (current-module)))
+ (pass-if "calling generic, one method, applicable"
+ (eval '(begin
+ (define-method (quxy (q <qux>))
+ #t)
+ (define q (make <qux>))
+ (quxy q))
+ (current-module)))
+ (pass-if-exception "calling generic, one method, not applicable"
+ exception:no-applicable-method
+ (eval '(quxy 1)
+ (current-module))))
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; These tests make some questionable assumptions.
+;;;
;;; - They assume that a GC will find all dead objects, so they
;;; will become flaky if we have a generational GC.
+;;;
+;;; - More generally, when a weakly referenced object doesn't disappear as
+;;; expected, it's hard to tell whether that's because of a guardian bug of
+;;; because a reference to it is being held somewhere, e.g., one some part
+;;; of the stack that hasn't been overwritten. Thus, most tests cannot
+;;; fail, they can just throw `unresolved'. We try hard to clear
+;;; references that may have been left on the stacks (see "clear refs left
+;;; on the stack" lines).
+;;;
;;; - They assume that objects won't be saved by the guardian until
;;; they explicitly invoke GC --- in other words, they assume that GC
;;; won't happen too often.
(gc)
;;; Who guards the guardian?
+
+;;; Note: We use strings rather than symbols because symbols are usually
+;;; ``interned'', i.e., kept in a weakly-keyed hash table, thus making them
+;;; inappropriate for the tests below. Furthermore, we use `string-copy' in
+;;; order to make sure that no string is kept around in the interpreter
+;;; unwillingly (e.g., in the source-property weak hash table).
+
(gc)
(define g2 (make-guardian))
-(g2 (list 'g2-garbage))
+(g2 (list (string-copy "g2-garbage")))
(define g3 (make-guardian))
-(g3 (list 'g3-garbage))
+(g3 (list (string-copy "g3-garbage")))
(g3 g2)
(pass-if "g2-garbage not collected yet" (equal? (g2) #f))
(pass-if "g3-garbage not collected yet" (equal? (g3) #f))
(if saved
(begin
(cond
- ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t))
+ ((equal? saved (list (string-copy "g3-garbage")))
+ (set! seen-g3-garbage #t))
((procedure? saved) (set! seen-g2 saved))
- (else (pk saved) (set! seen-something-else #t)))
+ (else (pk 'junk saved) (set! seen-something-else #t)))
(loop)))))
(pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
(pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
(pass-if "nothing else saved" (not seen-something-else))
+
+ ;; FIXME: The following test fails because the guardian for `g2-garbage'
+ ;; disappared from the weak-car guardian list of `g2-garbage' right before
+ ;; `g2-garbage' was finalized (in `finalize_guarded ()'). Sample session
+ ;; (compiled with `-DDEBUG_GUARDIANS'):
+ ;;
+ ;; guile> (define g (make-guardian))
+ ;; guile> (let ((g2 (make-guardian)))
+ ;; (format #t "g2 = ~x~%" (object-address g2))
+ ;; (g2 (string-copy "foo"))
+ ;; (g g2))
+ ;; g2 = 81fde18
+ ;; guile> (gc)
+ ;; finalizing guarded 0x827f6a0 (1 guardians)
+ ;; guardian for 0x827f6a0 vanished
+ ;; end of finalize (0x827f6a0)
+ ;; finalizing guarded 0x81fde18 (1 guardians)
+ ;; end of finalize (0x81fde18)
+
(pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
- (equal? (seen-g2) '(g2-garbage)))
+ (equal? (seen-g2)
+ (list (string-copy
+ "g2-garbage"))))
(throw 'unresolved))))
(with-test-prefix "standard guardian functionality"
(let ((g (make-guardian)))
(gc)
(g (cons #f #f))
+ (cons 'clear 'stack) ;; clear refs left on the stack
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(g (cons #f #f))
(g (cons #t #t))
+ (cons 'clear 'stack) ;; clear refs left on the stack
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(let ((g (make-guardian)))
(gc)
(g (cons #f #f))
+ (cons 'clear 'stack) ;; clear refs left on the stack
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(let ((p (cons #f #f)))
(g p)
- (vector-set! v 0 p))
+ (vector-set! v 0 p)
+ (set! p #f)) ;; clear refs left on the stack
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(let ((p (cons #f #f)))
(g p)
- (vector-set! v 0 p))
+ (vector-set! v 0 p)
+ (set! p #f)) ;; clear refs left on the stack
(begin
(gc)
(if (not (equal? (g) (cons #f #f)))
(pass-if "element of guarded weak vector gets collected"
(let ((g (make-guardian))
- (v (weak-vector (cons #f #f))))
+ (v (weak-vector #f)))
+ ;; Note: We don't pass `(cons #f #f)' as an argument to `weak-vector'
+ ;; otherwise references to it are likely to be left on the stack.
+ (vector-set! v 0 (cons #f #f))
+
(g v)
(gc)
(if (equal? (vector-ref v 0) (cons #f #f))
(gc)
(let ((p (cons #f #f)))
(g p)
- (g p))
+ (g p)
+ (set! p #f)) ;; clear refs left on the stack
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(let ((p (cons #f #f)))
(g p)
- (h p))
+ (h p)
+ (set! p #f)) ;; clear refs left on the stack
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2009 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
(pass-if-exception "illegal proc"
exception:wrong-type-arg
(let ((x (make-hook 1)))
+ ;; Currently fails to raise an exception
+ ;; because we can't usefully get any arity
+ ;; information out of interpreted procedures. A
+ ;; FIXME I guess.
+ (throw 'unresolved)
(add-hook! x bad-proc)))
(pass-if-exception "illegal hook"
exception:wrong-type-arg
-;;;; i18n.test --- Exercise the i18n API.
+;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*-
;;;;
-;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
-;;;; Ludovic Courtès
+;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(define %french-locale-name
"fr_FR.ISO-8859-1")
+(define %french-utf8-locale-name
+ "fr_FR.UTF-8")
+
+(define %turkish-utf8-locale-name
+ "tr_TR.UTF-8")
+
(define %french-locale
(false-if-exception
(make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
%french-locale-name)))
-(define (under-french-locale-or-unresolved thunk)
+(define %french-utf8-locale
+ (false-if-exception
+ (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
+ %french-utf8-locale-name)))
+
+(define %turkish-utf8-locale
+ (false-if-exception
+ (make-locale LC_ALL
+ %turkish-utf8-locale-name)))
+
+(define (under-locale-or-unresolved locale thunk)
;; On non-GNU systems, an exception may be raised only when the locale is
;; actually used rather than at `make-locale'-time. Thus, we must guard
;; against both.
- (if %french-locale
- (catch 'system-error thunk
- (lambda (key . args)
- (throw 'unresolved)))
+ (if locale
+ (if (string-contains %host-type "-gnu")
+ (thunk)
+ (catch 'system-error thunk
+ (lambda (key . args)
+ (throw 'unresolved))))
(throw 'unresolved)))
+(define (under-french-locale-or-unresolved thunk)
+ (under-locale-or-unresolved %french-locale thunk))
+
+(define (under-french-utf8-locale-or-unresolved thunk)
+ (under-locale-or-unresolved %french-utf8-locale thunk))
+
+(define (under-turkish-utf8-locale-or-unresolved thunk)
+ (under-locale-or-unresolved %turkish-utf8-locale thunk))
+
(with-test-prefix "text collation (French)"
(pass-if "string-locale<?"
(under-french-locale-or-unresolved
(lambda ()
- (string-locale<? "été" "hiver" %french-locale))))
+ (string-locale<? "été" "hiver" %french-locale))))
(pass-if "char-locale<?"
(under-french-locale-or-unresolved
(lambda ()
- (char-locale<? #\é #\h %french-locale))))
+ (char-locale<? #\é #\h %french-locale))))
(pass-if "string-locale-ci=?"
(under-french-locale-or-unresolved
(lambda ()
- (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
+ (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
+
+ (pass-if "string-locale-ci=? (2 args, wide strings)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ ;; Note: Character `œ' is not part of Latin-1, so these are wide
+ ;; strings.
+ (dynamic-wind
+ (lambda ()
+ (setlocale LC_ALL "fr_FR.UTF-8"))
+ (lambda ()
+ (string-locale-ci=? "œuf" "ŒUF"))
+ (lambda ()
+ (setlocale LC_ALL "C"))))))
+
+ (pass-if "string-locale-ci=? (3 args, wide strings)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ (string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))
(pass-if "string-locale-ci<>?"
(under-french-locale-or-unresolved
(lambda ()
- (and (string-locale-ci<? "été" "Hiver" %french-locale)
- (string-locale-ci>? "HiVeR" "été" %french-locale)))))
+ (and (string-locale-ci<? "été" "Hiver" %french-locale)
+ (string-locale-ci>? "HiVeR" "été" %french-locale)))))
+
+ (pass-if "string-locale-ci<>? (wide strings)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ ;; One of the strings is UCS-4, the other is Latin-1.
+ (and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
+ (string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))
+
+ (pass-if "string-locale-ci<>? (wide and narrow strings)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ ;; One of the strings is UCS-4, the other is Latin-1.
+ (and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
+ (string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))
(pass-if "char-locale-ci<>?"
(under-french-locale-or-unresolved
(lambda ()
- (and (char-locale-ci<? #\é #\H %french-locale)
- (char-locale-ci>? #\h #\É %french-locale))))))
+ (and (char-locale-ci<? #\é #\H %french-locale)
+ (char-locale-ci>? #\h #\É %french-locale)))))
+
+ (pass-if "char-locale-ci<>? (wide)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ (and (char-locale-ci<? #\o #\œ %french-utf8-locale)
+ (char-locale-ci>? #\Œ #\e %french-utf8-locale))))))
\f
(with-test-prefix "character mapping"
(pass-if "char-locale-upcase"
(and (eq? #\Z (char-locale-upcase #\z))
- (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C"))))))
+ (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
+
+ (pass-if "char-locale-upcase Turkish"
+ (under-turkish-utf8-locale-or-unresolved
+ (lambda ()
+ ;; This test is disabled for now, because char-locale-upcase is
+ ;; incomplete.
+ (throw 'untested)
+ (eq? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
+
+ (pass-if "char-locale-downcase Turkish"
+ (under-turkish-utf8-locale-or-unresolved
+ (lambda ()
+ ;; This test is disabled for now, because char-locale-downcase
+ ;; is incomplete.
+ (throw 'untested)
+ (eq? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))
+
+\f
+(with-test-prefix "string mapping"
+
+ (pass-if "string-locale-downcase"
+ (and (string=? "a" (string-locale-downcase "A"))
+ (string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))
+
+ (pass-if "string-locale-upcase"
+ (and (string=? "Z" (string-locale-upcase "z"))
+ (string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))
+
+ (pass-if "string-locale-upcase Turkish"
+ (under-turkish-utf8-locale-or-unresolved
+ (lambda ()
+ ;; This test is disabled for now, because string-locale-upcase
+ ;; is incomplete.
+ (throw 'untested)
+ (string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
+
+ (pass-if "string-locale-downcase Turkish"
+ (under-turkish-utf8-locale-or-unresolved
+ (lambda ()
+ ;; This test is disabled for now, because
+ ;; string-locale-downcase is incomplete.
+ (throw 'untested)
+ (string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))
\f
(with-test-prefix "number parsing"
(string-ci=? result "Tuesday"))))
(lambda ()
(setlocale LC_ALL "C")))))))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; mode: scheme
-;;; End:
-;;; R5RS null environment
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
+;;;; keywords.test --- Keywords -*- Scheme -*-
+;;;;
+;;;; Copyright (C) 2009 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
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;; Code:
+(define-module (test-keywords)
+ :use-module (test-suite lib))
+
+\f
+(with-test-prefix "keywords"
+ (pass-if "printing"
+ (string=? (with-output-to-string (lambda () (write #:this)))
+ "#:this")))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
;;;; numbers.test --- tests guile's numbers -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009 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
;;;
;;; miscellaneous
;;;
-(setbinary)
(define exception:numerical-overflow
(cons 'numerical-overflow "^Numerical overflow"))
(with-test-prefix "gcd"
- (expect-fail "documented?"
+ (pass-if "documented?"
(documented? gcd))
(with-test-prefix "(n)"
(with-test-prefix "lcm"
;; FIXME: more tests?
;; (some of these are already in r4rs.test)
- (expect-fail (documented? lcm))
+ (pass-if (documented? lcm))
(pass-if (= (lcm) 1))
(pass-if (= (lcm 32 -36) 288))
(let ((big-n 115792089237316195423570985008687907853269984665640564039457584007913129639936) ; 2 ^ 256
;;;
(with-test-prefix "="
- (expect-fail (documented? =))
+ (pass-if (documented? =))
(pass-if (= 0 0))
(pass-if (= 7 7))
(pass-if (= -7 -7))
(with-test-prefix "<"
- (expect-fail "documented?"
+ (pass-if "documented?"
(documented? <))
(with-test-prefix "(< 0 n)"
(big*4 (* fixnum-max 4))
(big*5 (* fixnum-max 5)))
- (expect-fail (documented? min))
+ (pass-if (documented? min))
(pass-if (= 1 (min 7 3 1 5)))
(pass-if (= 1 (min 1 7 3 5)))
(pass-if (= 1 (min 7 3 5 1)))
(with-test-prefix "+"
- (expect-fail "documented?"
+ (pass-if "documented?"
(documented? +))
(with-test-prefix "wrong type argument"
(with-test-prefix "/"
- (expect-fail "documented?"
+ (pass-if "documented?"
(documented? /))
(with-test-prefix "division by zero"
;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009 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
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-optargs)
- :use-module (test-suite lib)
- :use-module (ice-9 optargs))
-
-(with-test-prefix "optional argument processing"
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (ice-9 optargs))
+
+(define exception:unrecognized-keyword
+ ;; Can be `vm-error' or `misc-error' depending on whether we use the
+ ;; interpreter or VM:
+ ;; (vm-error vm-run "Bad keyword argument list: unrecognized keyword" ())
+ ;; (misc-error #f "~A ~S" ("unrecognized keyword" (#:y 2)) #f)
+ (cons #t ".*"))
+
+(define exception:extraneous-arguments
+ ;; Can be `vm-error' or `misc-error' depending on whether we use the
+ ;; interpreter or VM, and depending on the evenness of the number of extra
+ ;; arguments (!).
+ (cons #t ".*"))
+
+
+(define-syntax c&e
+ (syntax-rules (pass-if pass-if-exception)
+ ((_ (pass-if test-name exp))
+ (begin (pass-if (string-append test-name " (eval)")
+ (primitive-eval 'exp))
+ (pass-if (string-append test-name " (compile)")
+ (compile 'exp #:to 'value #:env (current-module)))))
+ ((_ (pass-if-exception test-name exc exp))
+ (begin (pass-if-exception (string-append test-name " (eval)")
+ exc (primitive-eval 'exp))
+ (pass-if-exception (string-append test-name " (compile)")
+ exc (compile 'exp #:to 'value
+ #:env (current-module)))))))
+
+(define-syntax with-test-prefix/c&e
+ (syntax-rules ()
+ ((_ section-name exp ...)
+ (with-test-prefix section-name (c&e exp) ...))))
+
+(with-test-prefix/c&e "optional argument processing"
(pass-if "local defines work with optional arguments"
(eval '(begin
(define* (test-1 #:optional (x 0))
;;; let-keywords
;;;
-(with-test-prefix "let-keywords"
+(with-test-prefix/c&e "let-keywords"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;;; let-keywords*
;;;
-(with-test-prefix "let-keywords*"
+(with-test-prefix/c&e "let-keywords*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;;; let-optional
;;;
-(with-test-prefix "let-optional"
+(with-test-prefix/c&e "let-optional"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
;;; let-optional*
;;;
-(with-test-prefix "let-optional*"
+(with-test-prefix/c&e "let-optional*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
(let ((rest '(123)))
(let-optional* rest ((foo 999))
(= foo 123)))))
+
+(define* (foo a b #:optional c (d 1) (e c) f #:key g (h a) (i r) #:rest r)
+ (list a b c d e f g h i r))
+
+;; So we could use lots more tests here, but the fact that lambda* is in
+;; the compiler, and the compiler compiles itself, using the evaluator
+;; (when bootstrapping) and compiled code (when doing a partial rebuild)
+;; makes me a bit complacent.
+(with-test-prefix/c&e "define*"
+ (pass-if "the whole enchilada"
+ (equal? (foo 1 2)
+ '(1 2 #f 1 #f #f #f 1 () ())))
+
+ (pass-if-exception "extraneous arguments"
+ exception:extraneous-arguments
+ (let ((f (lambda* (#:key x) x)))
+ (f 1 2 #:x 'x)))
+
+ (pass-if-exception "unrecognized keyword"
+ exception:unrecognized-keyword
+ (let ((f (lambda* (#:key x) x)))
+ (f #:y 'not-recognized)))
+
+ (pass-if "rest given before keywords"
+ ;; Passing the rest argument before the keyword arguments should not
+ ;; prevent keyword argument binding.
+ (let ((f (lambda* (#:key x y z #:rest r) (list x y z r))))
+ (equal? (f 1 2 3 #:x 'x #:z 'z)
+ '(x #f z (1 2 3 #:x x #:z z))))))
;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
-;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009 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
\f
;;;; Some general utilities for testing ports.
-;;; Make sure we are set up for 8-bit data
-(setbinary)
+;; Make sure we are set up for 8-bit Latin-1 data.
+(fluid-set! %default-port-encoding "ISO-8859-1")
+(for-each (lambda (p)
+ (set-port-encoding! p (fluid-ref %default-port-encoding)))
+ (list (current-input-port) (current-output-port)
+ (current-error-port)))
;;; Read from PORT until EOF, and return the result as a string.
(define (read-all port)
;; macro has been modified to fit into our test suite machinery.
(define-module (test-suite test-r5rs-pitfall)
- :use-syntax (ice-9 syncase)
:use-module (test-suite lib))
(define-syntax should-be
;;; All these tests assume Guile 1.8's port system, where characters are
;;; treated as octets.
-;;; Set the default encoding of future ports to be binary
-(setbinary)
+;; Set the default encoding of future ports to be Latin-1.
+(fluid-set! %default-port-encoding #f)
\f
(with-test-prefix "7.2.5 End-of-File Object"
;;;; ramap.test --- test array mapping functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2009 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
(array-map! (make-array #f 5) number->string))
(pass-if-exception "dsubr" exception:wrong-num-args
- (array-map! (make-array #f 5) $sqrt))
+ (array-map! (make-array #f 5) sqrt))
(pass-if "rpsubr"
(let ((a (make-array 'foo 5)))
(pass-if "dsubr"
(let ((a (make-array #f 5)))
- (array-map! a $sqrt (make-array 16.0 5))
+ (array-map! a sqrt (make-array 16.0 5))
(equal? a (make-array 4.0 5))))
(pass-if "rpsubr"
(make-array #f 5) (make-array #f 5))
(equal? a (make-array 'foo 5))))
- (pass-if-exception "subr_1" exception:wrong-type-arg
+ (pass-if-exception "subr_1" exception:wrong-num-args
(array-map! (make-array #f 5) length
(make-array #f 5) (make-array #f 5)))
(make-array 32 5) (make-array 16 5))
(equal? a (make-array "20" 5))))
- (pass-if "dsubr"
+ (pass-if-exception "dsubr" exception:wrong-num-args
(let ((a (make-array #f 5)))
- (array-map! a $sqrt
+ (array-map! a sqrt
(make-array 16.0 5) (make-array 16.0 5))
(equal? a (make-array 4.0 5))))
;;;; reader.test --- Exercise the reader. -*- Scheme -*-
;;;;
-;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009 Free Software Foundation, Inc.
;;;; Jim Blandy <jimb@red-bean.com>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite reader)
+ :use-module (srfi srfi-1)
:use-module (test-suite lib))
(define exception:unexpected-rparen
(cons 'read-error "unexpected \")\"$"))
(define exception:unterminated-block-comment
- (cons 'read-error "unterminated `#! ... !#' comment$"))
+ (cons 'read-error "unterminated `#. \\.\\.\\. .#' comment$"))
(define exception:unknown-character-name
(cons 'read-error "unknown character name .*$"))
(define exception:unknown-sharp-object
(equal? '(+ 2)
(read-string "(+ 2 #! a comment\n!#\n) ")))
+ (pass-if "R6RS/SRFI-30 block comment"
+ (equal? '(+ 1 2 3)
+ (read-string "(+ 1 #| this is a\ncomment |# 2 3)")))
+
+ (pass-if "R6RS/SRFI-30 nested block comment"
+ (equal? '(a b c)
+ (read-string "(a b c #| d #| e |# f |#)")))
+
+ (pass-if "R6RS/SRFI-30 block comment syntax overridden"
+ ;; To be compatible with 1.8 and earlier, we should be able to override
+ ;; this syntax.
+ (let ((rhp read-hash-procedures))
+ (dynamic-wind
+ (lambda ()
+ (read-hash-extend #\| (lambda args 'not)))
+ (lambda ()
+ (fold (lambda (x y result)
+ (and result (eq? x y)))
+ #t
+ (read-string "(this is #| a comment)")
+ `(this is not a comment)))
+ (lambda ()
+ (set! read-hash-procedures rhp)))))
+
(pass-if "unprintable symbol"
;; The reader tolerates unprintable characters for symbols.
(equal? (string->symbol "\001\002\003")
(pass-if-exception "unterminated block comment"
exception:unterminated-block-comment
(read-string "(+ 1 #! comment\n..."))
+ (pass-if-exception "R6RS/SRFI-30 unterminated nested block comment"
+ exception:unterminated-block-comment
+ (read-string "(foo #| bar #| |#)"))
(pass-if-exception "unknown character name"
exception:unknown-character-name
(read-string "#\\theunknowncharacter"))
--- /dev/null
+;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; coding: utf-8 -*-
+;;;;
+;;;; Copyright (C) 2009 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
+
+(define-module (test-records)
+ #:use-module (test-suite lib))
+
+;; ascii names and symbols
+(define rtd-foo (make-record-type "foo" '(x y)))
+(define make-foo (record-constructor rtd-foo))
+(define foo? (record-predicate rtd-foo))
+(define get-foo-x (record-accessor rtd-foo 'x))
+(define get-foo-y (record-accessor rtd-foo 'y))
+(define set-foo-x! (record-modifier rtd-foo 'x))
+(define set-foo-y! (record-modifier rtd-foo 'y))
+
+;; non-Latin-1 names and symbols
+(define rtd-fŏŏ (make-record-type "fŏŏ" '(x ȳ)))
+(define make-fŏŏ (record-constructor rtd-fŏŏ))
+(define fŏŏ? (record-predicate rtd-fŏŏ))
+(define get-fŏŏ-x (record-accessor rtd-fŏŏ 'x))
+(define get-fŏŏ-ȳ (record-accessor rtd-fŏŏ 'ȳ))
+(define set-fŏŏ-x! (record-modifier rtd-fŏŏ 'x))
+(define set-fŏŏ-ȳ! (record-modifier rtd-fŏŏ 'ȳ))
+
+(with-test-prefix "records"
+
+ (with-test-prefix "constructor"
+
+ (pass-if-exception "0 args (2 required)" exception:wrong-num-args
+ (make-foo))
+
+ (pass-if-exception "1 arg (2 required)" exception:wrong-num-args
+ (make-foo 1))
+
+ (pass-if "2 args (2 required)" exception:wrong-num-args
+ (foo? (make-foo 1 2)))
+
+ (pass-if "non-latin-1" exception:wrong-num-args
+ (fŏŏ? (make-fŏŏ 1 2))))
+
+ (with-test-prefix "modifier and getter"
+
+ (pass-if "set"
+ (let ((r (make-foo 1 2)))
+ (set-foo-x! r 3)
+ (eqv? (get-foo-x r) 3)))
+
+ (pass-if "set 2"
+ (let ((r (make-fŏŏ 1 2)))
+ (set-fŏŏ-ȳ! r 3)
+ (eqv? (get-fŏŏ-ȳ r) 3))))
+
+ (with-test-prefix "record type name"
+
+ (pass-if "foo"
+ (string=? "foo" (record-type-name rtd-foo)))
+
+ (pass-if "fŏŏ"
+ (string=? "fŏŏ" (record-type-name rtd-fŏŏ)))))
;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;;
-;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009 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
(define-module (test-suite test-regexp)
#:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 regex))
+;; Set the locale to LOC, if possible. Failing that, set the locale
+;; to C. If that fails, force the port encoding to ASCII.
+(define (mysetlocale loc)
+ (or
+ (and (defined? 'setlocale)
+ (false-if-exception (setlocale LC_ALL loc)))
+ (and (defined? 'setlocale)
+ (false-if-exception (setlocale LC_ALL "C")))
+ (begin
+ (false-if-exception (set-port-encoding! (current-input-port)
+ "ASCII"))
+ (false-if-exception (set-port-encoding! (current-output-port)
+ "ASCII"))
+ #f)))
+
+;; Set the locale to a Latin-1 friendly locale. Failing that, force
+;; the port encoding to Latin-1. Returns the encoding used.
+(define (set-latin-1)
+ (set-port-conversion-strategy! (current-output-port) 'escape)
+ (or
+ (any
+ (lambda (loc)
+ (if (defined? 'setlocale)
+ (let ((ret (false-if-exception (setlocale LC_ALL loc))))
+ (if ret
+ loc
+ #f))
+ #f))
+ (append
+ (map (lambda (name)
+ (string-append name ".ISO-8859-1"))
+ '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
+ (map (lambda (name)
+ (string-append name ".iso88591"))
+ '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
+ (map (lambda (name)
+ (string-append name ".ISO8859-1"))
+ '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
+ ))
+ (begin
+ (false-if-exception (set-port-encoding! (current-input-port)
+ "ISO-8859-1"))
+ (false-if-exception (set-port-encoding! (current-output-port)
+ "ISO-8859-1"))
+ #f)))
+
+(mysetlocale "C")
+
\f
;;; Run a regexp-substitute or regexp-substitute/global test, once
;;; providing a real port and once providing #f, requesting direct
;; try on each individual character, except #\nul
(do ((i 1 (1+ i)))
((>= i char-code-limit))
- (let* ((c (integer->char i))
- (s (string c))
- (q (regexp-quote s)))
- (pass-if (list "char" i c s q)
- (let ((m (regexp-exec (make-regexp q flag) s)))
- (and (= 0 (match:start m))
- (= 1 (match:end m)))))))
+ (let* ((c (integer->char i))
+ (s (string c))
+ (q (regexp-quote s)))
+ (pass-if (list "char" i (format #f "~s ~s ~s" c s q))
+ (set-latin-1) ; set locale for regexp processing
+ ; on binary data
+ (let ((m (regexp-exec (make-regexp q flag) s)))
+ (mysetlocale "") ; restore locale
+ (and (= 0 (match:start m))
+ (= 1 (match:end m)))))))
;; try on pattern "aX" where X is each character, except #\nul
;; this exposes things like "?" which are special only when they
;; follow a pattern to repeat or whatever ("a" in this case)
(do ((i 1 (1+ i)))
((>= i char-code-limit))
- (let* ((c (integer->char i))
- (s (string #\a c))
- (q (regexp-quote s)))
- (pass-if (list "string \"aX\"" i c s q)
- (let ((m (regexp-exec (make-regexp q flag) s)))
- (and (= 0 (match:start m))
- (= 2 (match:end m)))))))
+ (let* ((c (integer->char i))
+ (s (string #\a c))
+ (q (regexp-quote s)))
+ (pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
+ (set-latin-1)
+ (let* ((m (regexp-exec (make-regexp q flag) s)))
+ (mysetlocale "")
+ (and (= 0 (match:start m))
+ (= 2 (match:end m)))))))
(pass-if "string of all chars"
- (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
- flag) allchars)))
- (and (= 0 (match:start m))
- (= (string-length allchars) (match:end m))))))))
+ (set-latin-1)
+ (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
+ flag) allchars)))
+ (and (= 0 (match:start m))
+ (= (string-length allchars) (match:end m))))))))
lst)))
;;;
;;; regexp-substitute
;;;
+(mysetlocale "C")
(with-test-prefix "regexp-substitute"
(let ((match
--- /dev/null
+;;;; signals.test --- test suite for Guile's signal functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2009 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
+
+(define-module (test-suite test-signals)
+ #:use-module (test-suite lib))
+
+(with-test-prefix "sigaction"
+
+ (pass-if-exception "handler arg is an invalid integer"
+ exception:out-of-range
+ (sigaction SIGINT 51))
+
+ )
;;;; socket.test --- test socket functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 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
;;; AF_UNIX sockets and `make-socket-address'
;;;
+(define %tmpdir
+ ;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
+ (or (getenv "TMPDIR") "/tmp"))
+
+(define %curdir
+ ;; Remember the current working directory.
+ (getcwd))
+
+;; Temporarily cd to %TMPDIR. The goal is to work around path name
+;; limitations, which can lead to exceptions like:
+;;
+;; (misc-error "scm_to_sockaddr"
+;; "unix address path too long: ~A"
+;; ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619")
+;; #f)
+(chdir %tmpdir)
+
(define (temp-file-path)
- ;; Return a temporary file path that honors `$TMPDIR', which `tmpnam'
- ;; doesn't do.
- (let ((dir (or (getenv "TMPDIR") "/tmp")))
- (string-append dir "/guile-test-socket-"
- (number->string (current-time)) "-"
- (number->string (random 100000)))))
+ ;; Return a temporary file name, assuming the current directory is %TMPDIR.
+ (string-append "guile-test-socket-"
+ (number->string (current-time)) "-"
+ (number->string (random 100000))))
(if (defined? 'AF_UNIX)
(set! server-listening? #t)
#t)))
+ (force-output (current-output-port))
+ (force-output (current-error-port))
(if server-listening?
(let ((pid (primitive-fork)))
;; Spawn a server process.
#t)))
+
+(if (defined? 'AF_INET6)
+ (with-test-prefix "AF_INET6/SOCK_STREAM"
+
+ ;; testing `bind', `listen' and `connect' on stream-oriented sockets
+
+ (let ((server-socket (socket AF_INET6 SOCK_STREAM 0))
+ (server-bound? #f)
+ (server-listening? #f)
+ (server-pid #f)
+ (ipv6-addr 1) ; ::1
+ (server-port 8889)
+ (client-port 9998))
+
+ (pass-if "bind"
+ (catch 'system-error
+ (lambda ()
+ (bind server-socket AF_INET6 ipv6-addr server-port)
+ (set! server-bound? #t)
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args)))))))
+
+ (pass-if "bind/sockaddr"
+ (let* ((sock (socket AF_INET6 SOCK_STREAM 0))
+ (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
+ (catch 'system-error
+ (lambda ()
+ (bind sock sockaddr)
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args))))))))
+
+ (pass-if "listen"
+ (if (not server-bound?)
+ (throw 'unresolved)
+ (begin
+ (listen server-socket 123)
+ (set! server-listening? #t)
+ #t)))
+
+ (force-output (current-output-port))
+ (force-output (current-error-port))
+ (if server-listening?
+ (let ((pid (primitive-fork)))
+ ;; Spawn a server process.
+ (case pid
+ ((-1) (throw 'unresolved))
+ ((0) ;; the kid: serve two connections and exit
+ (let serve ((conn
+ (false-if-exception (accept server-socket)))
+ (count 1))
+ (if (not conn)
+ (exit 1)
+ (if (> count 0)
+ (serve (false-if-exception (accept server-socket))
+ (- count 1)))))
+ (exit 0))
+ (else ;; the parent
+ (set! server-pid pid)
+ #t))))
+
+ (pass-if "connect"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((s (socket AF_INET6 SOCK_STREAM 0)))
+ (connect s AF_INET6 ipv6-addr server-port)
+ #t)))
+
+ (pass-if "connect/sockaddr"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((s (socket AF_INET6 SOCK_STREAM 0)))
+ (connect s (make-socket-address AF_INET6 ipv6-addr server-port))
+ #t)))
+
+ (pass-if "accept"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((status (cdr (waitpid server-pid))))
+ (eq? 0 (status:exit-val status)))))
+
+ #t)))
+
+;; Switch back to the previous directory.
+(false-if-exception (chdir %curdir))
;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
-;;;; Copyright (C) 2003, 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2007, 2009 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
(with-test-prefix "sort"
(pass-if-exception "less function taking less than two arguments"
- exception:wrong-type-arg
+ exception:wrong-num-args
(sort '(1 2) (lambda (x) #t)))
(pass-if-exception "less function taking more than two arguments"
- exception:wrong-type-arg
+ exception:wrong-num-args
(sort '(1 2) (lambda (x y z) z)))
(pass-if "sort!"
;;;; srcprop.test --- test Guile source properties -*- scheme -*-
;;;;
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2009 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
(pass-if "setting the breakpoint property works"
(let ((s (read (open-input-string "(+ 3 4)"))))
+ (throw 'unresolved)
(set-source-property! s 'breakpoint #t)
(let ((current-trap-opts (evaluator-traps-interface))
(current-debug-opts (debug-options-interface))
(pass-if "setting the breakpoint property works"
(let ((s (read (open-input-string "(+ 3 4)"))))
+ (throw 'unresolved)
(set-source-properties! s '((breakpoint #t)))
(let ((current-trap-opts (evaluator-traps-interface))
(current-debug-opts (debug-options-interface))
;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009 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
(pass-if "empty list" (= 0 (count or1 '())))
- (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
(count (lambda () x) '(1 2 3)))
- (pass-if-exception "pred arg count 2" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 2" exception:wrong-num-args
(count (lambda (x y) x) '(1 2 3)))
(pass-if-exception "improper 1" exception:wrong-type-arg
(pass-if "empty lists" (= 0 (count or2 '() '())))
- (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
(count (lambda () #t) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 1" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 1" exception:wrong-num-args
(count (lambda (x) x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 3" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 3" exception:wrong-num-args
(count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
(pass-if-exception "improper first 1" exception:wrong-type-arg
(pass-if "empty list" (= 123 (fold + 123 '())))
- (pass-if-exception "proc arg count 0" exception:wrong-type-arg
+ (pass-if-exception "proc arg count 0" exception:wrong-num-args
(fold (lambda () x) 123 '(1 2 3)))
- (pass-if-exception "proc arg count 1" exception:wrong-type-arg
+ (pass-if-exception "proc arg count 1" exception:wrong-num-args
(fold (lambda (x) x) 123 '(1 2 3)))
- (pass-if-exception "proc arg count 3" exception:wrong-type-arg
+ (pass-if-exception "proc arg count 3" exception:wrong-num-args
(fold (lambda (x y z) x) 123 '(1 2 3)))
(pass-if-exception "improper 1" exception:wrong-type-arg
(pass-if "empty list" (eq? #f (list-index symbol? '())))
- (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
(list-index (lambda () x) '(1 2 3)))
- (pass-if-exception "pred arg count 2" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 2" exception:wrong-num-args
(list-index (lambda (x y) x) '(1 2 3)))
(pass-if-exception "improper 1" exception:wrong-type-arg
(pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
- (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
(list-index (lambda () #t) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 1" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 1" exception:wrong-num-args
(list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 3" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 3" exception:wrong-num-args
(list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
(pass-if-exception "improper first 1" exception:wrong-type-arg
;;;; srfi-10.test --- Test suite for Guile's SRFI-10 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009 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
(let* ((rx #,(rx "^foo$")))
(and (->bool (regexp-exec rx "foo"))
(not (regexp-exec rx "bar foo frob"))))))
+
+;; Disable SRFI-10 reader syntax again, to avoid messing up
+;; syntax-case's unsyntax
+(read-hash-extend #\, #f)
(with-test-prefix "string-any"
+ (pass-if "null string"
+ (not (string-any #\a "")))
+
+ (pass-if "start index == end index"
+ (not (string-any #\a "aaa" 1 1)))
+
(with-test-prefix "bad char_pred"
(pass-if-exception "integer" exception:wrong-type-arg
(with-test-prefix "string-every"
+ (pass-if "null string"
+ (string-every #\a ""))
+
+ (pass-if "start index == end index"
+ (string-every #\a "bbb" 1 1))
+
(with-test-prefix "bad char_pred"
(pass-if-exception "integer" exception:wrong-type-arg
(char-set->list (char-set #\a #\c #\e))
(list #\a #\c #\e))))
+(with-test-prefix "char set additition"
+
+ (pass-if "empty + x"
+ (let ((cs (char-set)))
+ (char-set-adjoin! cs #\x)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\x))))
+
+ (pass-if "x + y"
+ (let ((cs (char-set #\x)))
+ (char-set-adjoin! cs #\y)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\x #\y))))
+
+ (pass-if "x + w"
+ (let ((cs (char-set #\x)))
+ (char-set-adjoin! cs #\w)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\w #\x))))
+
+ (pass-if "x + z"
+ (let ((cs (char-set #\x)))
+ (char-set-adjoin! cs #\z)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\x #\z))))
+
+ (pass-if "x + v"
+ (let ((cs (char-set #\x)))
+ (char-set-adjoin! cs #\v)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\v #\x))))
+
+ (pass-if "uv + w"
+ (let ((cs (char-set #\u #\v)))
+ (char-set-adjoin! cs #\w)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\w))))
+
+ (pass-if "uv + t"
+ (let ((cs (char-set #\u #\v)))
+ (char-set-adjoin! cs #\t)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\t #\u #\v))))
+
+ (pass-if "uv + x"
+ (let ((cs (char-set #\u #\v)))
+ (char-set-adjoin! cs #\x)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\x))))
+
+ (pass-if "uv + s"
+ (let ((cs (char-set #\u #\v)))
+ (char-set-adjoin! cs #\s)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\s #\u #\v))))
+
+ (pass-if "uvx + w"
+ (let ((cs (char-set #\u #\v #\x)))
+ (char-set-adjoin! cs #\w)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\w #\x))))
+
+ (pass-if "uvx + y"
+ (let ((cs (char-set #\u #\v #\x)))
+ (char-set-adjoin! cs #\y)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\x #\y))))
+
+ (pass-if "uvxy + w"
+ (let ((cs (char-set #\u #\v #\x #\y)))
+ (char-set-adjoin! cs #\w)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\w #\x #\y)))))
+
+(with-test-prefix "char set union"
+ (pass-if "null U abc"
+ (char-set= (char-set-union (char-set) (->char-set "abc"))
+ (->char-set "abc")))
+
+ (pass-if "ab U ab"
+ (char-set= (char-set-union (->char-set "ab") (->char-set "ab"))
+ (->char-set "ab")))
+
+ (pass-if "ab U bc"
+ (char-set= (char-set-union (->char-set "ab") (->char-set "bc"))
+ (->char-set "abc")))
+
+ (pass-if "ab U cd"
+ (char-set= (char-set-union (->char-set "ab") (->char-set "cd"))
+ (->char-set "abcd")))
+
+ (pass-if "ab U de"
+ (char-set= (char-set-union (->char-set "ab") (->char-set "de"))
+ (->char-set "abde")))
+
+ (pass-if "abc U bcd"
+ (char-set= (char-set-union (->char-set "abc") (->char-set "bcd"))
+ (->char-set "abcd")))
+
+ (pass-if "abdf U abcdefg"
+ (char-set= (char-set-union (->char-set "abdf") (->char-set "abcdefg"))
+ (->char-set "abcdefg")))
+
+ (pass-if "abef U cd"
+ (char-set= (char-set-union (->char-set "abef") (->char-set "cd"))
+ (->char-set "abcdef")))
+
+ (pass-if "abgh U cd"
+ (char-set= (char-set-union (->char-set "abgh") (->char-set "cd"))
+ (->char-set "abcdgh")))
+
+ (pass-if "bc U ab"
+ (char-set= (char-set-union (->char-set "bc") (->char-set "ab"))
+ (->char-set "abc")))
+
+ (pass-if "cd U ab"
+ (char-set= (char-set-union (->char-set "cd") (->char-set "ab"))
+ (->char-set "abcd")))
+
+ (pass-if "de U ab"
+ (char-set= (char-set-union (->char-set "de") (->char-set "ab"))
+ (->char-set "abde")))
+
+ (pass-if "cd U abc"
+ (char-set= (char-set-union (->char-set "cd") (->char-set "abc"))
+ (->char-set "abcd")))
+
+ (pass-if "cd U abcd"
+ (char-set= (char-set-union (->char-set "cd") (->char-set "abcd"))
+ (->char-set "abcd")))
+
+ (pass-if "cde U abcdef"
+ (char-set= (char-set-union (->char-set "cde") (->char-set "abcdef"))
+ (->char-set "abcdef"))))
+
+(with-test-prefix "char set xor"
+ (pass-if "null - xy"
+ (char-set= (char-set-xor (char-set) (char-set #\x #\y))
+ (char-set #\x #\y)))
+
+ (pass-if "x - x"
+ (char-set= (char-set-xor (char-set #\x) (char-set #\x))
+ (char-set)))
+
+ (pass-if "xy - x"
+ (char-set= (char-set-xor (char-set #\x #\y) (char-set #\x))
+ (char-set #\y)))
+
+ (pass-if "xy - y"
+ (char-set= (char-set-xor (char-set #\x #\y) (char-set #\y))
+ (char-set #\x)))
+
+ (pass-if "wxy - w"
+ (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\w))
+ (char-set #\x #\y)))
+
+ (pass-if "wxy - x"
+ (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\x))
+ (char-set #\w #\y)))
+
+ (pass-if "wxy - y"
+ (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\y))
+ (char-set #\w #\x)))
+
+ (pass-if "uvxy - u"
+ (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\u))
+ (char-set #\v #\x #\y)))
+
+ (pass-if "uvxy - v"
+ (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\v))
+ (char-set #\u #\x #\y)))
+
+ (pass-if "uvxy - x"
+ (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\x))
+ (char-set #\u #\v #\y)))
+
+ (pass-if "uvxy - y"
+ (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\y))
+ (char-set #\u #\v #\x)))
+
+ (pass-if "uwy - u"
+ (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\u))
+ (char-set #\w #\y)))
+
+ (pass-if "uwy - w"
+ (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\w))
+ (char-set #\u #\y)))
+
+ (pass-if "uwy - y"
+ (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\y))
+ (char-set #\u #\w)))
+
+ (pass-if "uvwy - v"
+ (char-set= (char-set-xor (char-set #\u #\v #\w #\y) (char-set #\v))
+ (char-set #\u #\w #\y))))
+
(with-test-prefix "char-set?"
(not (char-set= (char-set #\a) (char-set))))
(pass-if "success, more args"
- (char-set= char-set:blank char-set:blank char-set:blank)))
+ (char-set= char-set:blank char-set:blank char-set:blank))
+
+ (pass-if "failure, same length, different elements"
+ (not (char-set= (char-set #\a #\b #\d) (char-set #\a #\c #\d)))))
(with-test-prefix "char-set<="
(pass-if "success, no arg"
(string=? (char-set->string cs)
"egilu"))))
-;; Make sure we get an ASCII charset and character classification.
-(if (defined? 'setlocale) (setlocale LC_CTYPE "C"))
+(with-test-prefix "list->char-set"
+
+ (pass-if "list->char-set"
+ (char-set= (list->char-set '(#\a #\b #\c))
+ (->char-set "abc")))
+
+ (pass-if "list->char-set!"
+ (let* ((cs (char-set #\a #\z)))
+ (list->char-set! '(#\m #\n) cs)
+ (char-set= cs
+ (char-set #\a #\m #\n #\z)))))
+
+(with-test-prefix "string->char-set"
+
+ (pass-if "string->char-set"
+ (char-set= (string->char-set "foobar")
+ (string->char-set "barfoo")))
+
+ (pass-if "string->char-set cs"
+ (char-set= (string->char-set "foo" (string->char-set "bar"))
+ (string->char-set "barfoo")))
+
+ (pass-if "string->char-set!"
+ (let ((cs (string->char-set "bar")))
+ (string->char-set! "foo" cs)
+ (char-set= cs
+ (string->char-set "barfoo")))))
+
+(with-test-prefix "char-set-filter"
+
+ (pass-if "filter w/o base"
+ (char-set=
+ (char-set-filter (lambda (c) (char=? c #\x))
+ (->char-set "qrstuvwxyz"))
+ (->char-set #\x)))
+
+ (pass-if "filter w/ base"
+ (char-set=
+ (char-set-filter (lambda (c) (char=? c #\x))
+ (->char-set "qrstuvwxyz")
+ (->char-set "op"))
+
+ (->char-set "opx")))
+
+ (pass-if "filter!"
+ (let ((cs (->char-set "abc")))
+ (set! cs (char-set-filter! (lambda (c) (char=? c #\x))
+ (->char-set "qrstuvwxyz")
+ cs))
+ (char-set= (string->char-set "abcx")
+ cs))))
+
+
+(with-test-prefix "char-set-intersection"
+
+ (pass-if "empty"
+ (char-set= (char-set-intersection (char-set) (char-set))
+ (char-set)))
+
+ (pass-if "identical, one element"
+ (char-set= (char-set-intersection (char-set #\a) (char-set #\a))
+ (char-set #\a)))
+
+ (pass-if "identical, two elements"
+ (char-set= (char-set-intersection (char-set #\a #\b) (char-set #\a #\b))
+ (char-set #\a #\b)))
+
+ (pass-if "identical, two elements"
+ (char-set= (char-set-intersection (char-set #\a #\c) (char-set #\a #\c))
+ (char-set #\a #\c)))
+
+ (pass-if "one vs null"
+ (char-set= (char-set-intersection (char-set #\a) (char-set))
+ (char-set)))
+
+ (pass-if "null vs one"
+ (char-set= (char-set-intersection (char-set) (char-set #\a))
+ (char-set)))
+
+ (pass-if "no elements shared"
+ (char-set= (char-set-intersection (char-set #\a #\c) (char-set #\b #\d))
+ (char-set)))
+
+ (pass-if "one elements shared"
+ (char-set= (char-set-intersection (char-set #\a #\c #\d) (char-set #\b #\d))
+ (char-set #\d))))
+
+(with-test-prefix "char-set-complement"
+
+ (pass-if "complement of null"
+ (char-set= (char-set-complement (char-set))
+ (char-set-union (ucs-range->char-set 0 #xd800)
+ (ucs-range->char-set #xe000 #x110000))))
+
+ (pass-if "complement of null (2)"
+ (char-set= (char-set-complement (char-set))
+ (ucs-range->char-set 0 #x110000)))
+
+ (pass-if "complement of #\\0"
+ (char-set= (char-set-complement (char-set #\nul))
+ (ucs-range->char-set 1 #x110000)))
+
+ (pass-if "complement of U+10FFFF"
+ (char-set= (char-set-complement (char-set (integer->char #x10ffff)))
+ (ucs-range->char-set 0 #x10ffff)))
+
+ (pass-if "complement of 'FOO'"
+ (char-set= (char-set-complement (->char-set "FOO"))
+ (char-set-union (ucs-range->char-set 0 (char->integer #\F))
+ (ucs-range->char-set (char->integer #\G)
+ (char->integer #\O))
+ (ucs-range->char-set (char->integer #\P)
+ #x110000))))
+ (pass-if "complement of #\\a #\\b U+010300"
+ (char-set= (char-set-complement (char-set #\a #\b (integer->char #x010300)))
+ (char-set-union (ucs-range->char-set 0 (char->integer #\a))
+ (ucs-range->char-set (char->integer #\c) #x010300)
+ (ucs-range->char-set #x010301 #x110000)))))
+
+(with-test-prefix "ucs-range->char-set"
+ (pass-if "char-set"
+ (char-set= (ucs-range->char-set 65 68)
+ (->char-set "ABC")))
+
+ (pass-if "char-set w/ base"
+ (char-set= (ucs-range->char-set 65 68 #f (->char-set "DEF"))
+ (->char-set "ABCDEF")))
+
+ (pass-if "char-set!"
+ (let ((cs (->char-set "DEF")))
+ (ucs-range->char-set! 65 68 #f cs)
+ (char-set= cs
+ (->char-set "ABCDEF")))))
+
+(with-test-prefix "char-set-count"
+ (pass-if "null"
+ (= 0 (char-set-count (lambda (c) #t) (char-set))))
+
+ (pass-if "count"
+ (= 5 (char-set-count (lambda (c) #t)
+ (->char-set "guile")))))
+
+(with-test-prefix "char-set-contains?"
+ (pass-if "#\\a not in null"
+ (not (char-set-contains? (char-set) #\a)))
+
+ (pass-if "#\\a is in 'abc'"
+ (char-set-contains? (->char-set "abc") #\a)))
+
+(with-test-prefix "any / every"
+ (pass-if "char-set-every #t"
+ (char-set-every (lambda (c) #t)
+ (->char-set "abc")))
+
+ (pass-if "char-set-every #f"
+ (not (char-set-every (lambda (c) (char=? c #\c))
+ (->char-set "abc"))))
+
+ (pass-if "char-set-any #t"
+ (char-set-any (lambda (c) (char=? c #\c))
+ (->char-set "abc")))
+
+ (pass-if "char-set-any #f"
+ (not (char-set-any (lambda (c) #f)
+ (->char-set "abc")))))
+
+(with-test-prefix "char-set-delete"
+ (pass-if "abc - a"
+ (char-set= (char-set-delete (->char-set "abc") #\a)
+ (char-set #\b #\c)))
+
+ (pass-if "abc - d"
+ (char-set= (char-set-delete (->char-set "abc") #\d)
+ (char-set #\a #\b #\c)))
+
+ (pass-if "delete! abc - a"
+ (let ((cs (char-set #\a #\b #\c)))
+ (char-set-delete! cs #\a)
+ (char-set= cs (char-set #\b #\c)))))
+
+(with-test-prefix "char-set-difference"
+ (pass-if "not different"
+ (char-set= (char-set-difference (->char-set "foobar") (->char-set "foobar"))
+ (char-set)))
+
+ (pass-if "completely different"
+ (char-set= (char-set-difference (->char-set "foo") (->char-set "bar"))
+ (->char-set "foo")))
+
+ (pass-if "partially different"
+ (char-set= (char-set-difference (->char-set "breakfast") (->char-set "breakroom"))
+ (->char-set "fst"))))
(with-test-prefix "standard char sets (ASCII)"
(define (every? pred lst)
(not (not (every pred lst))))
-(define (find-latin1-locale)
- ;; Try to find and install an ISO-8859-1 locale. Return `#f' on failure.
- (if (defined? 'setlocale)
- (let loop ((locales (map (lambda (lang)
- (string-append lang ".iso88591"))
- '("de_DE" "en_GB" "en_US" "es_ES"
- "fr_FR" "it_IT"))))
- (if (null? locales)
- #f
- (if (false-if-exception (setlocale LC_CTYPE (car locales)))
- (car locales)
- (loop (cdr locales)))))
- #f))
-
-
-(define %latin1 (find-latin1-locale))
+(define oldlocale #f)
+(if (defined? 'setlocale)
+ (set! oldlocale (setlocale LC_ALL "")))
(with-test-prefix "Latin-1 (8-bit charset)"
(pass-if "char-set:lower-case"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set
- (string-append "abcdefghijklmnopqrstuvwxyz"
- "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ")
- char-set:lower-case))))
+ (char-set<= (string->char-set
+ (string-append "abcdefghijklmnopqrstuvwxyz"
+ "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ")
+ char-set:lower-case)))
(pass-if "char-set:upper-case"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set
- (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ")
- char-set:lower-case))))
+ (char-set<= (string->char-set
+ (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ")
+ char-set:lower-case)))
(pass-if "char-set:title-case"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set "")
- char-set:title-case)))
+ (char-set<= (string->char-set "")
+ char-set:title-case))
(pass-if "char-set:letter"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set
- (string-append
- ;; Lowercase
- "abcdefghijklmnopqrstuvwxyz"
- "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ"
- ;; Uppercase
- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ"
- ;; Uncased
- "ªº"))
- char-set:letter)))
+ (char-set<= (string->char-set
+ (string-append
+ ;; Lowercase
+ "abcdefghijklmnopqrstuvwxyz"
+ "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ"
+ ;; Uppercase
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ"
+ ;; Uncased
+ "ªº"))
+ char-set:letter))
(pass-if "char-set:digit"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set "0123456789")
- char-set:digit)))
+ (char-set<= (string->char-set "0123456789")
+ char-set:digit))
(pass-if "char-set:hex-digit"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set "0123456789abcdefABCDEF")
- char-set:hex-digit)))
+ (char-set<= (string->char-set "0123456789abcdefABCDEF")
+ char-set:hex-digit))
(pass-if "char-set:letter+digit"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (char-set-union
- char-set:letter
- char-set:digit)
- char-set:letter+digit)))
+ (char-set<= (char-set-union
+ char-set:letter
+ char-set:digit)
+ char-set:letter+digit))
(pass-if "char-set:punctuation"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set
- (string-append "!\"#%&'()*,-./:;?@[\\]_{}"
- "¡«·»¿"))
- char-set:punctuation)))
+ (char-set<= (string->char-set
+ (string-append "!\"#%&'()*,-./:;?@[\\]_{}"
+ "¡«·»¿"))
+ char-set:punctuation))
(pass-if "char-set:symbol"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set
- (string-append "$+<=>^`|~"
- "¢£¤¥¦§¨©¬®¯°±´¶¸×÷"))
- char-set:symbol)))
+ (char-set<= (string->char-set
+ (string-append "$+<=>^`|~"
+ "¢£¤¥¦§¨©¬®¯°±´¶¸×÷"))
+ char-set:symbol))
;; Note that SRFI-14 itself is inconsistent here. Characters that
;; are non-digit numbers (such as category No) are clearly 'graphic'
;; but don't occur in the letter, digit, punct, or symbol charsets.
(pass-if "char-set:graphic"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (char-set-union
- char-set:letter
- char-set:digit
- char-set:punctuation
- char-set:symbol)
- char-set:graphic)))
+ (char-set<= (char-set-union
+ char-set:letter
+ char-set:digit
+ char-set:punctuation
+ char-set:symbol)
+ char-set:graphic))
(pass-if "char-set:whitespace"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set
- (string
- (integer->char #x09)
- (integer->char #x0a)
- (integer->char #x0b)
- (integer->char #x0c)
- (integer->char #x0d)
- (integer->char #x20)
- (integer->char #xa0)))
- char-set:whitespace)))
+ (char-set<= (string->char-set
+ (string
+ (integer->char #x09)
+ (integer->char #x0a)
+ (integer->char #x0b)
+ (integer->char #x0c)
+ (integer->char #x0d)
+ (integer->char #x20)
+ (integer->char #xa0)))
+ char-set:whitespace))
(pass-if "char-set:printing"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (char-set-union char-set:graphic char-set:whitespace)
- char-set:printing)))
+ (char-set<= (char-set-union char-set:graphic char-set:whitespace)
+ char-set:printing))
(pass-if "char-set:iso-control"
- (if (not %latin1)
- (throw 'unresolved)
- (char-set<= (string->char-set
- (apply string
- (map integer->char (append
- ;; U+0000 to U+001F
- (iota #x20)
- (list #x7f)
- ;; U+007F to U+009F
- (map (lambda (x) (+ #x80 x))
- (iota #x20))))))
- char-set:iso-control))))
-
+ (char-set<= (string->char-set
+ (apply string
+ (map integer->char (append
+ ;; U+0000 to U+001F
+ (iota #x20)
+ (list #x7f)
+ ;; U+007F to U+009F
+ (map (lambda (x) (+ #x80 x))
+ (iota #x20))))))
+ char-set:iso-control)))
+
+(if (defined? 'setlocale)
+ (setlocale LC_ALL oldlocale))
;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
-;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2008, 2009 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
(condition-type? &condition))
(pass-if "make-condition-type"
- (condition-type? (make-condition-type 'foo &condition '(a b)))))
+ (condition-type? (make-condition-type 'foo &condition '(a b))))
+
+ (pass-if "struct-vtable-name"
+ (let ((ct (make-condition-type 'chbouib &condition '(a b))))
+ (eq? 'chbouib (struct-vtable-name ct)))))
\f
(let ((s (substring/read-only "zyx" 0)))
(assq-ref (%string-dump s) 'read-only)))
- (pass-if "null strings are inlined"
- (let ((s ""))
- (assq-ref (%string-dump s) 'stringbuf-inline)))
-
- (pass-if "short Latin-1 encoded strings are inlined"
- (let ((s "m"))
- (assq-ref (%string-dump s) 'stringbuf-inline)))
-
- (pass-if "long Latin-1 encoded strings are not inlined"
- (let ((s "0123456789012345678901234567890123456789"))
- (not (assq-ref (%string-dump s) 'stringbuf-inline))))
-
- (pass-if "short UCS-4 encoded strings are not inlined"
- (let ((s "\u0100"))
- (not (assq-ref (%string-dump s) 'stringbuf-inline))))
-
- (pass-if "long UCS-4 encoded strings are not inlined"
- (let ((s "\u010012345678901234567890123456789"))
- (not (assq-ref (%string-dump s) 'stringbuf-inline))))
-
(pass-if "new Latin-1 encoded strings are not shared"
(let ((s "abc"))
(not (assq-ref (%string-dump s) 'stringbuf-shared))))
(let ((s "\U000040"))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))))
-(with-test-prefix "hex escapes"
+(with-test-prefix "escapes"
(pass-if-exception "non-hex char in two-digit hex-escape"
exception:illegal-escape
(integer->char #x010300)))
(pass-if "escaped characters match non-escaped ASCII characters"
- (string=? "ABC" "\x41\u0042\U000043")))
+ (string=? "ABC" "\x41\u0042\U000043"))
+
+ (pass-if "R5RS backslash escapes"
+ (string=? "\"\\" (string #\" #\\)))
+
+ (pass-if "Guile extensions backslash escapes"
+ (string=? "\0\a\f\n\r\t\v"
+ (apply string (map integer->char '(0 7 12 10 13 9 11))))))
+
+;;
+;; string?
+;;
+(with-test-prefix "string?"
+
+ (pass-if "string"
+ (string? "abc"))
+
+ (pass-if "symbol"
+ (not (string? 'abc))))
+
+;;
+;; string-null?
+;;
+
+(with-test-prefix "string-null?"
+
+ (pass-if "null string"
+ (string-null? ""))
+
+ (pass-if "non-null string"
+ (not (string-null? "a")))
+
+ (pass-if "respects \\0"
+ (not (string-null? "\0")))
+
+ (pass-if-exception "symbol"
+ exception:wrong-type-arg
+ (string-null? 'a)))
;;
;; string=?
;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*-
;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12.
;;;;
-;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009 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
(with-test-prefix "equal?"
(pass-if "simple structs"
- (let* ((vtable (make-vtable-vtable "pr" 0))
+ (let* ((vtable (make-vtable "pr"))
(s1 (make-struct vtable 0 "hello"))
(s2 (make-struct vtable 0 "hello")))
(equal? s1 s2)))
(string=? (symbol->string s)
(assq-ref (%symbol-dump s) 'stringbuf-chars))))
- (pass-if "the null symbol is inlined"
- (let ((s '#{}#))
- (assq-ref (%symbol-dump s) 'stringbuf-inline)))
-
- (pass-if "short Latin-1-encoded symbols are inlined"
- (let ((s 'm))
- (assq-ref (%symbol-dump s) 'stringbuf-inline)))
-
- (pass-if "long Latin-1-encoded symbols are not inlined"
- (let ((s 'x0123456789012345678901234567890123456789))
- (not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
-
- (pass-if "short UCS-4-encoded symbols are not inlined"
- (let ((s (string->symbol "\u0100")))
- (not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
-
- (pass-if "long UCS-4-encoded symbols are not inlined"
- (let ((s (string->symbol "\u010012345678901234567890123456789")))
- (not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
(with-test-prefix "hashes"
;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009 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
(define-module (test-suite test-syncase)
:use-module (test-suite lib))
-(pass-if "(ice-9 syncase) loads"
- (false-if-exception
- (begin (eval '(use-syntax (ice-9 syncase)) (current-module))
- #t)))
-
(define-syntax plus
(syntax-rules ()
((plus x ...) (+ x ...))))
(pass-if "@ works with syncase"
(eq? run-test (@ (test-suite lib) run-test)))
+
+(define-syntax string-let
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ id body ...)
+ #`(let ((id #,(symbol->string
+ (syntax->datum #'id))))
+ body ...)))))
+
+(pass-if "macro using quasisyntax"
+ (equal? (string-let foo (list foo foo))
+ '("foo" "foo")))
(define exception:bad-body
(cons 'misc-error "^bad body"))
(define exception:bad-formals
- '(syntax-error . "invalid parameter list"))
+ '(syntax-error . "invalid argument list"))
(define exception:bad-formal
(cons 'syntax-error "Bad formal"))
-(define exception:duplicate-formal
- (cons 'syntax-error "Duplicate formal"))
+(define exception:duplicate-formals
+ (cons 'syntax-error "duplicate identifier in argument list"))
(define exception:missing-clauses
(cons 'syntax-error "Missing clauses"))
(pass-if "legal (begin)"
(eval '(begin (begin) #t) (interaction-environment)))
- (with-test-prefix "unmemoization"
-
- ;; FIXME. I have no idea why, but the expander is filling in (if #f
- ;; #f) as the second arm of the if, if the second arm is missing. I
- ;; thought I made it not do that. But in the meantime, let's adapt,
- ;; since that's not what we're testing.
-
- (pass-if "normal begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
- (equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
-
- (pass-if "redundant nested begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))))
-
- (pass-if "redundant begin at start of body"
- (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (begin (+ 1) (+ 2)))))))
-
(pass-if-exception "illegal (begin)"
exception:generic-syncase-error
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
(with-test-prefix "lambda"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal lambda"
- (let ((foo (lambda () (lambda (x y) (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (lambda (_ _) (+ _ _))))))
-
- (pass-if "lambda with documentation"
- (let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (lambda (_ _) "docstring" (+ _ _)))))))
-
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x) 1)"
- exception:bad-formals
+ exception:duplicate-formals
(eval '(lambda (x x) 1)
(interaction-environment)))
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x x) 1)"
- exception:bad-formals
+ exception:duplicate-formals
(eval '(lambda (x x x) 1)
(interaction-environment))))
(with-test-prefix "let"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal let"
- (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
-
(with-test-prefix "bindings"
(pass-if-exception "late binding"
(with-test-prefix "let*"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal let*"
- (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
-
- (pass-if "let* without bindings"
- (let ((foo (lambda () (let ((x 1) (y 2))
- (let* ()
- (and (= x 1) (= y 2)))))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1) (_ 2))
- (if (= _ 1) (= _ 2) #f)))))))
-
(with-test-prefix "bindings"
(pass-if "(let* ((x 1) (x 2)) ...)"
(with-test-prefix "letrec"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal letrec"
- (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
- (matches? (procedure-source foo)
- (lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
-
(with-test-prefix "bindings"
(pass-if-exception "initial bindings are undefined"
exception:used-before-defined
(let ((x 1))
+ ;; FIXME: the memoizer does initialize the var to undefined, but
+ ;; the Scheme evaluator has no way of checking what's an
+ ;; undefined value. Not sure how to do this.
+ (throw 'unresolved)
(letrec ((x 1) (y x)) y))))
(with-test-prefix "bad bindings"
(with-test-prefix "if"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal if"
- (let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
- (foo #t) ; make sure, memoization has been performed
- (foo #f) ; make sure, memoization has been performed
- (matches? (procedure-source foo)
- (lambda (_) (if _ (+ 1) (+ 2))))))
-
- (expect-fail "if without else"
- (let ((foo (lambda (x) (if x (+ 1)))))
- (foo #t) ; make sure, memoization has been performed
- (foo #f) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (if x (+ 1))))))
-
- (expect-fail "if #f without else"
- (let ((foo (lambda () (if #f #f))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- `(lambda () (if #f #f))))))
-
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
- (with-test-prefix "unmemoization"
-
- ;; FIXME: the (if #f #f) is a hack!
- (pass-if "normal clauses"
- (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
- (equal? (procedure-source foo)
- '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
-
- (pass-if "else"
- (let ((foo (lambda () (cond (else 'bar)))))
- (equal? (procedure-source foo)
- '(lambda () 'bar))))
-
- ;; FIXME: the (if #f #f) is a hack!
- (pass-if "=>"
- (let ((foo (lambda () (cond (#t => identity)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ #t))
- (if _ (identity _) (if #f #f))))))))
-
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
- (with-test-prefix "unmemoization"
-
- (pass-if "normal clauses"
- (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
- (matches? (procedure-source foo)
- (lambda (_)
- (if ((@@ (guile) memv) _ '(1))
- 'bar
- (if ((@@ (guile) memv) _ '(2))
- 'baz
- 'foobar))))))
-
- (pass-if "empty labels"
- (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
- (matches? (procedure-source foo)
- (lambda (_)
- (if ((@@ (guile) memv) _ '(1))
- 'bar
- (if ((@@ (guile) memv) _ '())
- 'baz
- 'foobar)))))))
-
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
- (with-test-prefix "unmemoization"
-
- (pass-if "definition unmemoized without prior execution"
- (primitive-eval '(begin
- (define (blub) (cons ('(1 . 2)) 2))
- (equal?
- (procedure-source blub)
- '(lambda () (cons ('(1 . 2)) 2))))))
-
-
- (pass-if "definition with documentation unmemoized without prior execution"
- (primitive-eval '(begin
- (define (blub) "Comment" (cons ('(1 . 2)) 2))
- (equal?
- (procedure-source blub)
- '(lambda () "Comment" (cons ('(1 . 2)) 2)))))))
-
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
(pass-if-exception "missing body expression"
exception:missing-body-expr
(eval '(let () (define x #t))
- (interaction-environment)))
-
- (pass-if "unmemoization"
- (primitive-eval '(begin
- (define (foo)
- (define (bar)
- 'ok)
- (bar))
- (foo)
- (matches?
- (procedure-source foo)
- (lambda () (letrec ((_ (lambda () (quote ok)))) (_))))))))
+ (interaction-environment))))
(with-test-prefix "set!"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal set!"
- (let ((foo (lambda (x) (set! x (+ 1 x)))))
- (foo 1) ; make sure, memoization has been performed
- (matches? (procedure-source foo)
- (lambda (_) (set! _ (+ 1 _)))))))
-
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"
;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007, 2009 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
(pass-if "locking mutex with no owner"
(let ((m (make-mutex)))
(lock-mutex m #f #f)
- (not (mutex-owner m)))))
+ (not (mutex-owner m))))
+
+ (pass-if "mutex with owner not retained (bug #27450)"
+ (let ((g (make-guardian)))
+ (g (let ((m (make-mutex))) (lock-mutex m) m))
+
+ ;; Avoid false references to M on the stack.
+ (let cleanup ((i 20))
+ (and (> i 0)
+ (begin (cleanup (1- i)) i)))
+
+ (gc) (gc)
+ (let ((m (g)))
+ (and (mutex? m)
+ (eq? (mutex-owner m) (current-thread)))))))
;;
;; mutex lock levels
'out))))))
(define-syntax assert-tree-il->glil
- (syntax-rules ()
- ((_ in out)
- (pass-if 'in
- (let ((tree-il (strip-source (parse-tree-il 'in))))
- (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
- 'out))))))
-
-(define-syntax assert-tree-il->glil/pmatch
(syntax-rules ()
((_ in pat test ...)
(let ((exp 'in))
(with-test-prefix "void"
(assert-tree-il->glil
(void)
- (program 0 0 0 () (void) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
(assert-tree-il->glil
(begin (void) (const 1))
- (program 0 0 0 () (const 1) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
- (program 0 0 0 () (void) (call add1 1) (call return 1))))
+ (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
(apply (toplevel foo) (const 1))
- (program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call goto/args 1)))
+ (assert-tree-il->glil
(begin (apply (toplevel foo) (const 1)) (void))
- (program 0 0 0 () (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
- (program 0 0 0 () (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call goto/args 1))))
(with-test-prefix "conditional"
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(if (const #t) (const 1) (const 2))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(begin (if (const #t) (const 1) (const 2)) (const #f))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1))
(eq? l1 l3) (eq? l2 l4))
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(apply (primitive null?) (if (const #t) (const 1) (const 2)))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
(const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4)
(call null? 1) (call return 1))
(with-test-prefix "primitive-ref"
(assert-tree-il->glil
(primitive +)
- (program 0 0 0 () (toplevel ref +) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
- (program 0 0 0 () (const #f) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (primitive +))
- (program 0 0 0 () (toplevel ref +) (call null? 1)
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1))))
(with-test-prefix "lexical refs"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1)
(unbind))))
;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1))
(set! (lexical x y) (apply (primitive 1+) (lexical x y))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(void) (call return 1)
(let (x) (y) ((const 1))
(begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
(lexical x y)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(lexical #t #t ref 0) (call return 1)
(let (x) (y) ((const 1))
(apply (primitive null?)
(set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
(call null? 1) (call return 1)
(with-test-prefix "module refs"
(assert-tree-il->glil
(@ (foo) bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@ (foo) bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call null? 1) (call return 1)))
(assert-tree-il->glil
(@@ (foo) bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@@ (foo) bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call null? 1) (call return 1))))
(with-test-prefix "module sets"
(assert-tree-il->glil
(set! (@ (foo) bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
(assert-tree-il->glil
(set! (@@ (foo) bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel refs"
(assert-tree-il->glil
(toplevel bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call return 1)))
(assert-tree-il->glil
(begin (toplevel bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (toplevel bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call null? 1) (call return 1))))
(with-test-prefix "toplevel sets"
(assert-tree-il->glil
(set! (toplevel bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel defines"
(assert-tree-il->glil
(define bar (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (define bar (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (define bar (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "constants"
(assert-tree-il->glil
(const 2)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call return 1)))
(assert-tree-il->glil
(begin (const 2) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda"
(assert-tree-il->glil
- (lambda (x) (y) () (const 2))
- (program 0 0 0 ()
- (program 1 0 0 ()
- (bind (x #f 0))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (x #f 0)) (label _)
+ (const 2) (call return 1) (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x x1) (y y1) () (const 2))
- (program 0 0 0 ()
- (program 2 0 0 ()
- (bind (x #f 0) (x1 #f 1))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x y) #f #f #f () (x1 y1))
+ (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 2 2 #f)
+ (bind (x #f 0) (y #f 1)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda x y () (const 2))
- (program 0 0 0 ()
- (program 1 1 0 ()
- (bind (x #f 0))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case ((() #f x #f () (y)) (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 0 0 0 1 #f)
+ (bind (x #f 0)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (const 2))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (lexical x y))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (lexical #t #f ref 0) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (lexical #t #f ref 0) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (lexical x1 y1))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (lexical #t #f ref 1) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (lexical #t #f ref 1) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
- (program 0 0 0 ()
- (program 1 0 0 ()
- (bind (x #f 0))
- (program 1 0 0 ()
- (bind (y #f 0))
- (lexical #f #f ref 0) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f #f #f () (x1))
+ (lambda ()
+ (lambda-case (((y) #f #f #f () (y1))
+ (lexical x x1))
+ #f)))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (x #f 0)) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (y #f 0)) (label _)
+ (lexical #f #f ref 0) (call return 1)
+ (unbind))
(lexical #t #f ref 0)
(call vector 1)
(call make-closure 2)
- (call return 1))
+ (call return 1)
+ (unbind))
(call return 1))))
(with-test-prefix "sequence"
(assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const #t) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case
(with-test-prefix "the or hack"
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical a b))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
(eq? l1 l2))
;; second bound var is unreferenced
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical x y))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
(with-test-prefix "apply"
(assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar))
- (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
+ (assert-tree-il->glil
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1))))
(with-test-prefix "call/cc"
(assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo))
- (program 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call goto/cc 1)))
+ (assert-tree-il->glil
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(assert-tree-il->glil
(apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))
(1+ y))
0
(parse-tree-il
- '(lambda (x y) (x1 y1)
- (apply (toplevel +)
- (lexical x x1)
- (lexical y y1)))))))
+ '(lambda ()
+ (lambda-case
+ (((x y) #f #f #f () (x1 y1))
+ (apply (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))
+ #f))))))
(and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1)
(make-lexical-ref #f 'x 'x1)
(make-toplevel-ref #f '+)))
- (= (length downs) 2)
+ (= (length downs) 3)
(equal? (reverse (map strip-source ups))
(map strip-source downs))))))
(define %opts-w-unused
'(#:warnings (unused-variable)))
+(define %opts-w-unbound
+ '(#:warnings (unbound-variable)))
+
+(define %opts-w-arity
+ '(#:warnings (arity-mismatch)))
+
(with-test-prefix "warnings"
(null? (call-with-warnings
(lambda ()
(compile '(lambda (x y z) #t)
- #:opts %opts-w-unused)))))))
+ #:opts %opts-w-unused))))))
+
+ (with-test-prefix "unbound variable"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '+ #:opts %opts-w-unbound)))))
+
+ (pass-if "ref"
+ (let* ((v (gensym))
+ (w (call-with-warnings
+ (lambda ()
+ (compile v
+ #:to 'assembly
+ #:opts %opts-w-unbound)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ (format #f "unbound variable `~A'"
+ v))))))
+
+ (pass-if "set!"
+ (let* ((v (gensym))
+ (w (call-with-warnings
+ (lambda ()
+ (compile `(set! ,v 7)
+ #:to 'assembly
+ #:opts %opts-w-unbound)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ (format #f "unbound variable `~A'"
+ v))))))
+
+ (pass-if "module-local top-level is visible"
+ (let ((m (make-module))
+ (v (gensym)))
+ (beautify-user-module! m)
+ (compile `(define ,v 123)
+ #:env m #:opts %opts-w-unbound)
+ (null? (call-with-warnings
+ (lambda ()
+ (compile v
+ #:env m
+ #:to 'assembly
+ #:opts %opts-w-unbound))))))
+
+ (pass-if "module-local top-level is visible after"
+ (let ((m (make-module))
+ (v (gensym)))
+ (beautify-user-module! m)
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string
+ "(define (f)
+ (set! chbouib 3))
+ (define chbouib 5)")))
+ (read-and-compile in
+ #:env m
+ #:opts %opts-w-unbound)))))))
+
+ (pass-if "optional arguments are visible"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(lambda* (x #:optional y z) (list x y z))
+ #:opts %opts-w-unbound
+ #:to 'assembly)))))
+
+ (pass-if "keyword arguments are visible"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(lambda* (x #:key y z) (list x y z))
+ #:opts %opts-w-unbound
+ #:to 'assembly)))))
+
+ (pass-if "GOOPS definitions are visible"
+ (let ((m (make-module))
+ (v (gensym)))
+ (beautify-user-module! m)
+ (module-use! m (resolve-interface '(oop goops)))
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string
+ "(define-class <foo> ()
+ (bar #:getter foo-bar))
+ (define z (foo-bar (make <foo>)))")))
+ (read-and-compile in
+ #:env m
+ #:opts %opts-w-unbound))))))))
+
+ (with-test-prefix "arity mismatch"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
+
+ (pass-if "direct application"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+ (pass-if "local"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (lambda (x y) (+ x y))))
+ (f 2))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "global"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(cons 1 2 3 4)
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "alias to global"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((f cons)) (f 1 2 3 4))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "alias to lexical to global"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((f number?))
+ (let ((g f))
+ (f 1 2 3 4)))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "alias to lexical"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (lambda (x y z) (+ x y z))))
+ (let ((g f))
+ (g 1)))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "letrec"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(letrec ((odd? (lambda (x) (even? (1- x))))
+ (even? (lambda (x)
+ (or (= 0 x)
+ (odd?)))))
+ (odd? 1))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "case-lambda"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (case-lambda
+ ((x) 1)
+ ((x y) 2)
+ ((x y z) 3))))
+ (list (f 1)
+ (f 1 2)
+ (f 1 2 3)))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+
+ (pass-if "case-lambda with wrong number of arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (case-lambda
+ ((x) 1)
+ ((x y) 2))))
+ (f 1 2 3))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "case-lambda*"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (case-lambda*
+ ((x #:optional y) 1)
+ ((x #:key y) 2)
+ ((x y #:key z) 3))))
+ (list (f 1)
+ (f 1 2)
+ (f #:y 2)
+ (f 1 2 #:z 3)))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+
+ (pass-if "case-lambda* with wrong arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (case-lambda*
+ ((x #:optional y) 1)
+ ((x #:key y) 2)
+ ((x y #:key z) 3))))
+ (list (f)
+ (f 1 #:z 3)))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 2)
+ (null? (filter (lambda (w)
+ (not
+ (number?
+ (string-contains
+ w "wrong number of arguments to"))))
+ w)))))
+
+ (pass-if "local toplevel-defines"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string "
+ (define (g x) (f x))
+ (define (f) 1)")))
+ (read-and-compile in
+ #:opts %opts-w-arity
+ #:to 'assembly))))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "global toplevel alias"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string "
+ (define f cons)
+ (define (g) (f))")))
+ (read-and-compile in
+ #:opts %opts-w-arity
+ #:to 'assembly))))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "local toplevel overrides global"
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string "
+ (define (cons) 0)
+ (define (foo x) (cons))")))
+ (read-and-compile in
+ #:opts %opts-w-arity
+ #:to 'assembly))))))
+
+ (pass-if "keyword not passed and quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (lambda* (x #:key y) y)))
+ (f 2))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+
+ (pass-if "keyword passed and quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (lambda* (x #:key y) y)))
+ (f 2 #:y 3))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+
+ (pass-if "keyword passed to global and quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string "
+ (use-modules (system base compile))
+ (compile '(+ 2 3) #:env (current-module))")))
+ (read-and-compile in
+ #:opts %opts-w-arity
+ #:to 'assembly))))))
+
+ (pass-if "extra keyword"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (lambda* (x #:key y) y)))
+ (f 2 #:Z 3))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
+ (pass-if "extra keywords allowed"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
+ y)))
+ (f 2 #:Z 3))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))))
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-unif)
- #:use-module (test-suite lib))
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib))
;;;
;;; array?
(eq? 'b (array-ref a -2)))))
(pass-if-exception "negative length" exception:length-non-negative
- (with-input-from-string "'#1:-3(#t #t)" read)))
+ (with-input-from-string "'#1:-3(#t #t)" read))
+ (pass-if "bitvector is self-evaluating"
+ (equal? (compile (bitvector)) (bitvector))))
;;;
;;; equal? with vector and one-dimensional array
(pass-if "simple vector"
(equal? '(1 2 3) (vector->list #(1 2 3))))
+ (pass-if "string vector 1"
+ (equal? '("abc" "def" "ghi") (vector->list #("abc" "def" "ghi"))))
+
+ (pass-if "string-vector 2"
+ (equal? '("abc\u0100" "def\u0101" "ghi\u0102")
+ (vector->list #("abc\u0100" "def\u0101" "ghi\u0102"))))
+
(pass-if "shared array"
(let ((b (make-shared-array #(1) (lambda (x) '(0)) 2)))
(equal? b (list->vector (vector->list b))))))
+(with-test-prefix "make-vector"
+
+ (pass-if "null"
+ (equal? #() (make-vector 0)))
+
+ (pass-if "fill with num"
+ (equal? #(1 1 1) (make-vector 3 1)))
+
+ (pass-if "fill with string"
+ (equal? #("abc" "abc" "abc") (make-vector 3 "abc")))
+
+ (pass-if "fill with string 2"
+ (equal? #("ab\u0100" "ab\u0100" "ab\u0100")
+ (make-vector 3 "ab\u0100"))))
+
;;;; weaks.test --- tests guile's weaks -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009 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
(define global-weak (make-weak-vector 10 #f))
(begin
- (vector-set! global-weak 0 "string")
- (vector-set! global-weak 1 "beans")
- (vector-set! global-weak 2 "to")
- (vector-set! global-weak 3 "utah")
- (vector-set! global-weak 4 "yum yum")
+ (vector-set! global-weak 0 (string-copy "string"))
+ (vector-set! global-weak 1 (string-copy "beans"))
+ (vector-set! global-weak 2 (string-copy "to"))
+ (vector-set! global-weak 3 (string-copy "utah"))
+ (vector-set! global-weak 4 (string-copy "yum yum"))
(gc))
;;; Normal weak vectors